Excel VBA поиск по идентификатору и импорт данных из другого листа

Question

Я работаю над проектом с большим количеством данных на двух разных листах, которые нужно объединить. Например:

Мой Sheet1 должен содержать 4 столбца. Столбцы 1 и 2 уже заполнены ID и status. В Sheet2 у меня есть 3 столбца. Первый снова содержит ID, второй a serial-number, а третий a Yes/No.

В двух листах содержится около 5500 строк. Первый чуть больше второго.

Я хотел бы запустить al oop, который выбирает первый ID в Sheet1, проверяет, существует ли он в Sheet2, и если это так, следует скопировать два отсутствующих столбца (serial-number и Yes/No) в Sheet1.

Затем перейдите к следующему Id в Sheet1 и повторите то же самое.

Я попробовал это с кодом ниже, но я не получаю его работать.

Надеюсь, вы поможете мне!

    Dim i As Long
    Dim Found As Range

    For i = 1 To Rows.Count

        Worksheets("Sheet1").Activate

        If Cells(i, 1).Value <> "" Then

            Set Found = Worksheets("Sheet2").Range("A2", Range("A")).Find(i, 1)

            If Not Found Is Nothing Then

            Worksheets("Sheet1").Range(i, 3).Value = Cells(Found.Row, 2).Value
            Worksheets("Sheet1").Range(i, 4).Value = Cells(Found.Row, 3).Value

            End If
        End If
    Next i

Answer 1

Массивы перед диапазонами

• Настройте значения в разделе констант в соответствии со своими потребностями. Делайте это осторожно (медленно), потому что их много.
• Сначала я создал второй код, который оказался очень медленным. После внедрения массивов он стал в 30 раз быстрее при 5000 записях. Я думаю, что дополнительная работа окупается.

Option Explicit

Sub UpdateSheetArray() ' Calculates for about 3s at 5000 records - Acceptable!

    Const strSrc As String = "Sheet2"   ' Source Worksheet Name
    Const frSrc As Long = 2             ' Source First Row Number
    Const colSrc As Long = 1            ' Source Compare Column Number
    Const colSrc1 As Long = 2           ' Source Data Column 1
    Const colSrc2 As Long = 3           ' Source Data Column 2

    Const strTgt As String = "Sheet1"   ' Target Worksheet Name
    Const frTgt As Long = 1             ' Target First Row Number
    Const colTgt As Long = 1            ' Target Compare Column Number
    Const colTgt1 As Long = 3           ' Target Data Column 1
    Const colTgt2 As Long = 4           ' Target Data Column 2

    Dim wsSrc As Worksheet              ' Source Worksheet
    Dim wsTgt As Worksheet              ' Target Worksheet
    Dim vntSrc As Variant               ' Source Compare Array
    Dim vntSrc1 As Variant              ' Source Data Array 1
    Dim vntSrc2 As Variant              ' Source Data Array 2
    Dim vntTgt As Variant               ' Target Compare Array
    Dim vntTgt1 As Variant              ' Target Data Array 1
    Dim vntTgt2 As Variant              ' Target Data Array 2
    Dim rngSrc As Range                 ' Source Compare Range,
                                        ' Source Data Range 1,
                                        ' Source Data Range 2
    Dim rngTgt As Range                 ' Target Compare Range,
                                        ' Target Data Range 1,
                                        ' Target Data Range 2
    Dim lrSrc As Long                   ' Source Last Non-Empty Row Number
    Dim lrTgt As Long                   ' Target Last Non-Empty Row Number
    Dim varCur As Variant               ' Current Target Cell Value
    Dim i As Long                       ' Source Row Counter
    Dim j As Long                       ' Target Row Counter

    ' Define Source and Target Worksheets.
    Set wsSrc = Worksheets(strSrc)
    Set wsTgt = Worksheets(strTgt)

    ' Calculate Last Non-Empty Row in Source Worksheet.
    lrSrc = wsSrc.Columns(colSrc).Find(What:="*", LookIn:=xlFormulas, _
      SearchDirection:=xlPrevious).Row
    ' Calculate Last Non-Empty Row in Target Worksheet.
    lrTgt = wsTgt.Columns(colTgt).Find(What:="*", LookIn:=xlFormulas, _
      SearchDirection:=xlPrevious).Row

    ' Define Source Compare Range and write its values to Source Compare Array.
    Set rngSrc = wsSrc.Cells(frSrc, colSrc).Resize(lrSrc - frSrc + 1)
    vntSrc = rngSrc
    ' Define Source Data Range 1 and write its values to Source Data Array 1.
    Set rngSrc = rngSrc.Offset(, colSrc1 - colSrc): vntSrc1 = rngSrc
    ' Define Source Data Range 2 and write its values to Source Data Array 2.
    Set rngSrc = rngSrc.Offset(, colSrc2 - colSrc1): vntSrc2 = rngSrc

    ' Define Target Compare Range and write its values to Target Compare Array.
    Set rngTgt = wsTgt.Cells(frTgt, colTgt).Resize(lrTgt - frTgt + 1)
    vntTgt = rngTgt
    ' Define Target Data Arrays (same size as Target Compare Array).
    ReDim vntTgt1(1 To UBound(vntTgt), 1 To 1)
    ReDim vntTgt2(1 To UBound(vntTgt), 1 To 1)
    ' Note: These last two arrays are going to be written to,
    '       while the previous four are going to be read from.
    '       All arrays are 2-dimensional 1-based 1-column arrays.

    ' Loop through elements of Target Compare Array.
    For i = 1 To UBound(vntTgt)
        ' Write value of current element in Target Array
        ' to Current Target Cell Value.
        varCur = vntTgt(i, 1)
        ' Check if Current Target Cell Value is not "".
        If varCur <> "" Then
            ' Loop through elements of Source Compare Array.
            For j = 1 To UBound(vntSrc)
                ' Check if value of current element in Source Array is equal
                ' to Current Target Cell Value.
                If vntSrc(j, 1) = varCur Then
                    ' Write current elements in Source Data Arrays
                    ' to Target Data Arrays.
                    vntTgt1(i, 1) = vntSrc1(j, 1): vntTgt2(i, 1) = vntSrc2(j, 1)
                    ' No need to loop anymore after found.
                    Exit For
                End If
            Next
        End If
    Next

    ' Define Target Data Range 1.
    Set rngTgt = rngTgt.Offset(, colTgt1 - colTgt)
    ' Write values of Target Data Array 1 to Target Data Range 1.
    rngTgt = vntTgt1
    ' Define Target Data Range 2.
    Set rngTgt = rngTgt.Offset(, colTgt2 - colTgt1)
    ' Write values of Target Data Array 2 to Target Data Range 2.
    rngTgt = vntTgt2

End Sub

Sub UpdateSheetRange() ' Calculates for about 90s at 5000 records - too slow!

    Const strSrc As String = "Sheet2"   ' Source Worksheet Name
    Const frSrc As Long = 2             ' Source First Row Number
    Const colSrc As Long = 1            ' Source Compare Column Number
    Const colSrc1 As Long = 2           ' Source Data Column 1
    Const colSrc2 As Long = 3           ' Source Data Column 2

    Const strTgt As String = "Sheet1"   ' Target Worksheet Name
    Const frTgt As Long = 1             ' Target First Row Number
    Const colTgt As Long = 1            ' Target Compare Column Number
    Const colTgt1 As Long = 3           ' Target Data Column 1
    Const colTgt2 As Long = 4           ' Target Data Column 2

    Dim wsSrc As Worksheet              ' Source Worksheet
    Dim wsTgt As Worksheet              ' Target Worksheet
    Dim lrSrc As Long                   ' Source Last Non-Empty Row Number
    Dim lrTgt As Long                   ' Target Last Non-Empty Row Number
    Dim varCur As Variant               ' Current Target Cell Value
    Dim i As Long                       ' Source Row Counter
    Dim j As Long                       ' Target Row Counter

    ' Define Worksheet.
    Set wsSrc = Worksheets(strSrc)
    Set wsTgt = Worksheets(strTgt)

    ' Calculate Last Non-Empty Row in Source Worksheet.
    lrSrc = wsSrc.Columns(colSrc).Find(What:="*", LookIn:=xlFormulas, _
      SearchDirection:=xlPrevious).Row
    ' Calculate Last Non-Empty Row in Target Worksheet.
    lrTgt = wsTgt.Columns(colTgt).Find(What:="*", LookIn:=xlFormulas, _
      SearchDirection:=xlPrevious).Row

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    On Error GoTo ProgramError

    For i = frTgt To lrTgt
        varCur = wsTgt.Cells(i, colTgt).Value
        If varCur <> "" Then
            For j = frSrc To lrSrc
                If wsSrc.Cells(j, colSrc).Value = varCur Then
                    wsTgt.Cells(i, colTgt1) = wsSrc.Cells(j, colSrc1).Value
                    wsTgt.Cells(i, colTgt2) = wsSrc.Cells(j, colSrc2).Value
                    Exit For
                End If
            Next
        End If
    Next

SafeExit:

    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

Exit Sub

ProgramError:

    MsgBox "An unexpected error occurred."
    On Error GoTo 0
    GoTo SafeExit

End Sub

Answer 2

Вы можете попробовать с двумя вложенными для каждого цикла.

Sub copySerial()
Dim range1 As Range, range2 As Range

Set range1 = Worksheets("Sheet1").Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
Set range2 = Worksheets("Sheet2").Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)

For Each c1 In range1
    For Each c2 In range2
        If c1.Value = c2.Value Then
            c1.Offset(0, 2).Value = c2.Offset(0, 1).Value
            c1.Offset(0, 3).Value = c2.Offset(0, 2).Value
        End If
    Next c2
Next c1

End Sub