VBA останавливается до того, как это будет сделано

Question

У меня проблема ...

У меня есть два набора данных в одной книге на разных листах. Первый столбец в обоих наборах данных - идентификаторы. В Sheet1 у меня есть свой набор данных, и я хочу заполнить его данными из Sheet2 (который также содержит данные (строки + столбцы), которые я не хочу использовать.

У меня есть VBA, который работает, НО , он останавливается до того, как это будет сделано. Например, у меня 1598 строк в Sheet2, но он перестает работать уже после 567 строк ..

Sub Test()
    Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet

    Set Source = ActiveWorkbook.Worksheets("Sheet2")
    Set Target = ActiveWorkbook.Worksheets("Sheet1")

    j = 2    
    For Each c In Source.Range("A2", Source.Range("A" & Source.Cells(Source.Rows.Count, "A").End(xlUp).Row))
        If c = Target.Cells(j, 1).Value Then
           Source.Range("D" & c.Row & ":AS" & c.Row).Copy Target.Cells(j, 26) 
           j = j + 1
        End If
    Next c
    MsgBox "Done"
End Sub

Может ли кто-нибудь помочь мне и посмотреть, есть ли что-то явно не так с кодом ? Я пробовал его на небольших наборах данных, и он работает идеально. Если требуется дополнительная информация или у вас есть другие советы, спросите / сообщите: D

Спасибо!

Answer 1

Решение VBA

Попробуйте следующее: используйте метод WorksheetFunction.Match , чтобы правильно сопоставить значения столбца A независимо от их порядка.

It просматривает все строки в Target и пытается найти соответствующую строку в Source. Если совпадение было найдено, оно копируется в Target.

Option Explicit

Public Sub Test()
    Dim Source As Worksheet
    Set Source = ThisWorkbook.Worksheets("Sheet2")

    Dim Target As Worksheet
    Set Target = ThisWorkbook.Worksheets("Sheet1")


    Dim LastRowTarget As Long
    LastRowTarget = Target.Cells(Target.Rows.Count, "A").End(xlUp).Row

    Dim tRow As Long
    For tRow = 2 To LastRowTarget
        Dim sRowMatch As Double
        sRowMatch = 0 'reset match row
        On Error Resume Next 'ignore if next line throws error
        sRowMatch = Application.WorksheetFunction.Match(Target.Cells(tRow, 1).Value, Source.Columns("A"), 0)
        On Error GoTo 0 're-enable error reporting

        If sRowMatch <> 0 Then 'if matching does not find anything it will be 0 so <>0 means something was found to copy
            Source.Range("D" & sRowMatch & ":AS" & sRowMatch).Copy Target.Cells(tRow, 26)
        End If
    Next tRow

    MsgBox "Done"
End Sub

Formula Solution

Обратите внимание, что нет необходимости в VBA, и это также может быть решено только с помощью формул. Либо формула VLOOKUP, либо комбинация формул INDEX и MATCH.

Итак, в ячейке Z2 листа 1 напишите =INDEX(Sheet2!D:D,MATCH($A2,Sheet2!$A:$A, 0)) и потяните вниз и вправо.