Excel VBA 搜索 id 並從其他工作表導入數據

Question

我正在做一個項目，在兩個不同的工作表中有很多數據，這些工作表要合並。 例如：

我的Sheet1應該包含 4 列。 第 1 列和第 2 列已經填充了ID和status 。 在 Sheet2 我有 3 列。 第一個包含ID ，第二個是serial-number ，第三個Yes/No 。

這兩張紙大約有 5500 行。 第一個比第二個多一點。

我想運行一個循環來選擇Sheet1的第一個ID ，檢查它是否存在於Sheet2中，如果存在，它應該將兩個缺失的列（ serial-number和Yes/No ）復制到Sheet1 。

然后到Sheet1的下一個Id並再次執行相同操作。

我用下面的代碼試過了，但我沒有讓它工作。

希望你能幫幫我！

    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

您可以嘗試為每個循環使用兩個嵌套。

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

Answer 2

Arrays 范圍前

• 調整常量部分中的值以滿足您的需要。 仔細（慢慢地）做，因為有很多。
• 首先，我創建了看起來超級慢的第二個代碼。 實施 arrays 后，它在 5000 條記錄時速度提高了 30 倍。 我想額外的工作是有回報的。

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