Перебирайте строки, содержащие имена файлов, и копируйте информацию в эти файлы.

Question

У меня есть главный файл, который содержит строки данных, которые я хочу скопировать в несколько файлов на основе имени файла в столбце I. Поэтому, если строки основного файла 2-4 имеют одинаковое имя файла в столбце I, скопируйте вседанные в столбцах AH в файл.Затем переместитесь вниз по электронной таблице, строки 5-10 имеют одинаковые имена файлов копировать столбцы AH.Данные должны быть вставлены после последней строки данных.

У меня есть код, который правильно открывает файлы, но он не проходит через каждую строку, как ожидалось.Я тестировал только имя, которое находится в столбце B

Sub Copy_Into_Files()

    Dim Date, FirstName, LastName, City  As String
    Dim SourceSheet, DestSheet As Worksheet
    Set SourceSheet = ThisWorkbook.Sheets("report")

    Dim lr As Long
    Dim i, erow As Integer
    Dim CopyTo As Workbook
    Dim FileNames As Variant

    With ThisWorkbook.Sheets("report")
        lr = .Cells(.Rows.Count, "I").End(xlUp).Row
        FileNames = .Range("I2:I" & lr).Value
    End With
    For i = 2 To lr
        On Error Resume Next
        If FileNames(i, 1) Like "*.xlsx" Then
            Set CopyTo = Workbooks.Open(FileNames(i, 1), _
                                           ReadOnly:=False, _
                                           Password:="")

           With CopyTo
            FirstName = SourceSheet.Cells(i, 2).Value
            Set DestSheet = Sheets("Sheet1")
            erow = DestSheet.Cells(DestSheet.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
            DestSheet.Cells(erow, 2).Value = FirstName
            MsgBox FirstName
           End With
        End If
        Set CopyTo = Nothing
    Next i
 End Sub

Код, похоже, правильно копирует один экземпляр имени, но не перемещается по всем строкам, которые соответствуют имени файла