Код Excel VBA для копирования строк на соответствующие именованные листы не работает

Question

Я нашел этот код на этом сайте из ответа на предыдущий вопрос двухлетней давности. Код просматривает строки данных на мастер-листе и копирует соответствующие строки на основе столбца D (проект) в именованный лист.

Если именованный лист не существует, в столбец D добавляется поле комментария, в котором указывается, что имя листа не существует.

Код также просматривает столбец A (Счет-фактура) и использует его в качестве уникального идентификатора, поэтому дублированные строки не копируются на именованные листы.

Я изменил код в соответствии со своими потребностями (названия листов и т. Д.), Но когда я запускаю код, соответствующая строка НЕ ​​копируется на указанный лист, а на следующий лист справа.

Я не могу понять, что не так с кодом. Надеюсь, кто-то может помочь !!!

Column A   Column B     Column C      Column D
Invoice    Date         Amount        Project
I18-1234   1/10/2018    $125.00       Project 1
I18-5678   10/10/2018   $1,500.00     Project 2
I18-2468   20/10/2018   $10,000.00    Project 1
I18-7931   15/10/2018   $300.00       Project 3
I18-1010   24/10/2018   $1,000.00     Project 1

У меня есть основной лист с именем "Master Sheet". Здесь вводятся все данные.

В настоящее время у меня есть еще один лист с именем "Проект 1".

Остальные листы, которые у меня есть, называются «Лист2» ​​и «Лист3». (Это как раз пока я проверяю код).

Sub Test()

Dim cell As Range
Dim cmt As Comment
Dim bolFound As Boolean
Dim sheetNames() As String
Dim lngItem As Long, lngLastRow As Long
Dim sht As Worksheet, shtMaster As Worksheet
Dim MatchRow As Variant

'Set master sheet
Set shtMaster = ThisWorkbook.Worksheets("Master Data")

   'Get the names for all other sheets
ReDim sheetNames(0)
For Each sht In ThisWorkbook.Worksheets
    If sht.Name <> shtMaster.Name Then
        sheetNames(UBound(sheetNames)) = sht.Name
        ReDim Preserve sheetNames(UBound(sheetNames) + 1)
    End If
Next sht
ReDim Preserve sheetNames(UBound(sheetNames) - 1)

For Each cell In shtMaster.Range("D2:D" & shtMaster.Cells(shtMaster.Rows.Count, "D").End(xlUp).Row)
bolFound = False

' instead of looping through the array of sheets >> use Application.Match
If Not IsError(Application.Match(cell.Value2, sheetNames, 0)) Then
    bolFound = True
    Set sht = ThisWorkbook.Worksheets(sheetNames(Application.Match(cell.Value2, sheetNames, 0)))

    ' now use a 2nd Match, to find matches in Unique column "A"
    MatchRow = Application.Match(cell.Offset(, -3).Value, sht.Range("A:A"), 0)
    If Not IsError(MatchRow) Then
        shtMaster.Rows(cell.Row).EntireRow.Copy Destination:=sht.Cells(MatchRow, 1)

    Else '<-- no match in sheet, add the record at the end
        On Error GoTo SetFirst
        lngLastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
        On Error GoTo 0
        shtMaster.Rows(cell.Row).EntireRow.Copy Destination:=sht.Cells(lngLastRow, 1)
    End If

End If

If bolFound = False Then
    For Each cmt In shtMaster.Comments
        If cmt.Parent.Address = cell.Address Then cmt.Delete
    Next cmt
    cell.AddComment "no sheet found for this row"
    ActiveSheet.EnableCalculation = False
    ActiveSheet.EnableCalculation = True
End If

Set sht = Nothing
Next
Exit Sub

SetFirst:
    lngLastRow = 1
    Resume Next

End Sub

Answer 1

измените свою часть кода:

' instead of looping through the array of sheets >> use Application.Match
If Not IsError(Application.Match(cell.Value2, sheetNames, 0)) Then
    bolFound = True
    Set sht = ThisWorkbook.Worksheets(sheetNames(Application.Match(cell.Value2, sheetNames, 0)))

на

' instead of looping through the array of sheets >> use Application.Match
If Not IsError(Application.Match(cell.Value2, sheetNames, 0)) Then
    bolFound = True
    Set sht = ThisWorkbook.Worksheets(cell.Value)