Заполнение файла Excel из других

Option Compare Text
Sub Сборка_по_идентификаторам()
    Const ColIdent = 1 ' Колонка идентификаторов совпадения
    Dim i&, j&, MyPath$, MyFileName$, LastRow1&, LastRow2&, LastCol&, Ident, A, B
    Dim wb1 As Workbook, wb2 As Workbook, sh1 As Worksheet, sh2 As Worksheet
    MyPath = "C:\TEMP\По_направлениям\" ' Обрабатываемая папка (не должна содержать сборный файл).
    Set wb1 = ActiveWorkbook
    MyFileName = Dir(MyPath & "*.xls*")
    Do Until MyFileName = ""
        Set wb2 = Workbooks.Open(FileName:=MyPath & MyFileName, UpdateLinks:=0, ReadOnly:=True)
        For Each sh1 In wb1
            Set sh2 = wb2.Worksheets(sh1.Name)
            LastRow2 = sh2.Cells(sh2.Rows.Count, ColIdent).End(xlUp).Row
            B = Range(sh2.Cells(1, ColIdent), sh2.Cells(LastRow2, ColIdent)).Value
            With sh1
                LastRow1 = .Cells(.Rows.Count, ColIdent).End(xlUp).Row
                LastCol = .UsedRange.Columns.Count - .UsedRange.Column + 1
                A = Range(.Cells(1, ColIdent), .Cells(LastRow1, ColIdent)).Value
                For i = 1 To LastRow2
                    Ident = Trim$(B(i, 1))
                    Range(sh2.Cells(i, 2), sh2.Cells(i, LastCol)).Copy
                    For j = 1 To LastRow1
                        If Trim$(A(j, 1)) = Ident Then
                           .Cells(j, 2).Paste
                           Exit For
                        End If
                    Next j
                Next i
            End With
        Next sh1
        wb2.Close 0
        MyFileName = Dir
    Loop
End Sub

        For Each sh1 In wb1.Worksheets

                           .Paste Destination:=sh1.Cells(j, 2)

                           .Paste Destination:=sh1.Cells(j, 1)