Sub rownong27()
Dim dic As Object, iTemp
Dim arr(), arr1(), arr2(), I&, J&, N1&, N2&
Dim arrTask(), arrReg(), U1&
Set dic = CreateObject("Scripting.Dictionary")
With Workbooks("Сотрудники на 18.02.2019.xlsx").Worksheets(1)
    arr = .Range("B12:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
End With
For I = 1 To UBound(arr)
    If Not IsEmpty(arr(I, 1)) Then iTemp = Trim(dic(arr(I, 1)))
Next
Application.ScreenUpdating = False
With Workbooks("Сводный файл Задач.xlsx").Worksheets("Лист1")
    With .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 12).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column))
        arr1 = .Value
        .ClearContents
    End With
End With
ReDim arrTask(1 To UBound(arr1, 1), 1 To UBound(arr1, 2)): N1 = 1
With Workbooks("Сводный файл Реестра.xlsx").Worksheets("Лист1")
    With .Range(.Cells(4, 1), .Cells(.Cells(.Rows.Count, 6).End(xlUp).Row, .Cells(3, .Columns.Count).End(xlToLeft).Column))
        arr2 = .Value
        .ClearContents
    End With
End With
ReDim arrReg(1 To UBound(arr2, 1), 1 To UBound(arr2, 2)): N2 = 1
U1 = IIf(UBound(arr1) >= UBound(arr2), UBound(arr1), UBound(arr2))
For I = 1 To U1
    If UBound(arr1) >= I Then
        If dic.Exists(Trim(arr1(I, 12))) Then
            arrTask(N1, 1) = CStr(arr1(I, 1))
            For J = 2 To UBound(arr1, 2): arrTask(N1, J) = arr1(I, J): Next
            N1 = N1 + 1
        End If
    End If
    If UBound(arr2) >= I Then
        If dic.Exists(Trim(arr2(I, 6))) Then
            For J = 1 To UBound(arr2, 2): arrReg(N2, J) = arr2(I, J): Next
            N2 = N2 + 1
        End If
    End If
Next
Workbooks("Сводный файл Задач.xlsx").Worksheets("Лист1").Cells(2, 1).Resize(N1, UBound(arr1, 2)) = arrTask
Workbooks("Сводный файл Реестра.xlsx").Worksheets("Лист1").Cells(4, 1).Resize(N2, UBound(arr2, 2)) = arrReg
Application.ScreenUpdating = True
End Sub