ActiveWorkbook.Worksheets("Факт").UsedRange  'сбросить результат с последней ячейкой, строкой
    ActiveWorkbook.Worksheets("Свод").UsedRange  'сбросить результат с последней ячейкой, строкой
    ' отключаем автофильтр
    If ActiveWorkbook.Sheets("Факт").FilterMode Then ActiveSheet.ShowAllData
    Dim co, vs As Long 'Dim r As Range
    ActiveWorkbook.Sheets("Факт").Activate
    co = Cells(Rows.Count, "D").End(xlUp).Row
    ActiveWorkbook.Sheets("Факт").Range("C4:D" & co).Copy
    ActiveWorkbook.Sheets("Свод").Activate
    ActiveSheet.UsedRange  'сбросить результат с последней ячейкой, строкой
    vs = Cells.SpecialCells(xlLastCell).Row + 2   'строчка верха массива после копирования на лист Свод
    Range("A" & vs).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("Свод").UsedRange  'сбросить результат с последней ячейкой, строкой
    PS = Cells.SpecialCells(xlLastCell).Row
    Selection.RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
    ActiveWorkbook.Worksheets("Свод").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Свод").Sort.SortFields.Add2 Key:=Range("B" & vs & ":B" & PS), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Свод").Sort
        .SetRange Range("A" & vs & ":B" & PS)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Worksheets("Свод").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Свод").Sort.SortFields.Add2 Key:=Range("A" & vs & ":A" & PS), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Свод").Sort
        .SetRange Range("A" & vs & ":B" & PS)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ' doober Выделить цветом почти похожие частично совпадающие ФИО
    Dim Rng As Range, res As Double, key1 As String, key2 As String
    Set Rng = Selection
    dx = Rng
    For n = 1 To UBound(dx)
        key1 = dx(n, 2)
        For i = 1 To UBound(dx)
            If i <> n Then
                key2 = dx(i, 2)
                If key2 <> "" And key2 <> "" Then
                    If Simil(key1, key2) >= 0.7 Then
                        Rng(i, 2).Interior.Color = 13431551
                        If i > n Then Exit For
                    End If
                End If
            End If
        Next
    Next
    ActiveWorkbook.Worksheets("Свод").UsedRange  'сбросить результат с последней ячейкой, строкой
    vs2 = Cells.SpecialCells(xlLastCell).Row  'vs2 низ массива и нижняя строка
    vs3 = Range("A" & vs & ":B" & vs2) '.Select ' массив дня переноса
    'Kuzmich Вставить массив ниже ячейки, содержащей ...
    Dim FoundCell As Range
    Dim Kol_vo As Integer
    Kol_vo = vs2 - vs + 1
    Rows("6:6").Copy
    Rows("7:7").Resize(Kol_vo).Insert Shift:=xlDown 'вставить количество строк как и в массиве, чтобы формулы и оформление границ сохранить
'    vs3.Copy Cells(6, 1)  ' Как вставить массив, который записан как переменная vs3?