VBA - 将 Sheet1 值与 Sheet2 进行比较，将结果复制/粘贴到 Sheet3

Question

我正在尝试将 sheet1“A”列值与 sheet2“E:E”列值进行比较，并将每个匹配项的整行复制/粘贴到 sheet3。请帮我完成这个任务。我对 VBA 很陌生。

非常感谢您！

Sub DelDups_TwoLists()
    Dim iListCount As Integer
    Dim iCtr As Integer

     ' Turn off screen updating to speed up macro.
    Application.ScreenUpdating = False

     ' Get count of records to search through (list that will be deleted).
    iListCount = Sheets("sheet1").Cells(Rows.Count, "A").End(xlUp).Row

     ' Loop through the "master" list.
    For Each x In Sheets("Sheet2").Range("E:E" & Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row)
         ' Loop through all records in the second list.
        For iCtr = iListCount To 1 Step -1
             ' Do comparison of next record.
             ' To specify a different column, change 1 to the column number.
            If x.Value = Sheets("Sheet1").Cells(iCtr, 1).Value Then
                 ' If match is true then delete row.
                Sheets("Sheet1").Cells(iCtr, 1).EntireRow.Copy
                Sheets("Sheet3").Select.Paste
            End If

        Next iCtr
    Next
    Application.ScreenUpdating = True
    MsgBox "Done!"
End Sub

Answer 1

Sub DelDupsTwoLists()

    Dim lastRowWs1 As Long, lastRowWs2 As Long
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Set ws1 = Worksheets(1)
    Set ws2 = Worksheets(2)
    Set ws3 = Worksheets(3)

    lastRowWs1 = LastRow(ws1.Name, 1)
    lastRowWs2 = LastRow(ws2.Name, 5) 'E = 5

    Dim myCell1 As Range, myCell2 As Range
    Dim ws1Range As Range, ws2Range As Range

    Set ws1Range = ws1.Range(ws1.Cells(1, "A"), ws1.Cells(lastRowWs1, 1))
    Set ws2Range = ws2.Range(ws2.Cells(1, "E"), ws2.Cells(lastRowWs2, 1))

    Dim rangeToDelete As Range

    For Each myCell1 In ws1Range
        For Each myCell2 In ws2Range

        If myCell1.Value = myCell2.Value Then
            Dim lastRowWs3: lastRowWs3 = LastRow(ws3.Name, 1) + 1
            myCell2.EntireRow.Copy Destination:=ws3.Cells(lastRowWs3, 1)

            If Not rangeToDelete Is Nothing Then
                Set rangeToDelete = Union(rangeToDelete, myCell2.EntireRow)
            Else
                Set rangeToDelete = myCell2.EntireRow
            End If

        End If
        Next
    Next

    If Not rangeToDelete Is Nothing Then
        Debug.Print "Deleting rangeToDelete - "; rangeToDelete.Address
        rangeToDelete.Delete
    End If
    Debug.Print "Done!"

End Sub

Public Function LastRow(wsName As String, Optional columnToCheck As Long = 1) As Long

    Dim ws As Worksheet
    Set ws = Worksheets(wsName)
    LastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row

End Function

我几乎从头开始重写了整个代码。它几乎使用了初始的n2 复杂性，但比这要快得多，因为删除WorkSheet(2) 中的行是在最后一步rangeToDelete.Delete 中完成的，这样可以节省大量时间。

差不多，代码定义了 2 个可以使用的范围 - ws1Range 和 ws2Range，使用 LastRow 函数。一旦定义了它们，它就会开始循环遍历它们并比较它们。因此n2 复杂性。如果值相等，则复制行并将单元格添加到rangeToDelete。

注意 - 它可能无法作为“开箱即用的解决方案”工作，但请尝试使用 F8 进一步调试，看看会发生什么。

另外：

• Using Integer is not a great idea in VBA。
• Sub 名称中的“_”用于 VBA 中的事件，因此使用它不是一个好主意。 （虽然有效）
• How to avoid using Select in Excel VBA

Answer 2

试一试（详情请参阅代码中的 cmets）：

Sub DelDups_TwoLists()

' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False

With ActiveWorkbook
    Dim wsSrc As Worksheet: Set wsSrc = .Sheets("Sheet1") 'declare and set the source worksheet
    Dim wsDst As Worksheet: Set wsDst = .Sheets("Sheet3") 'declare and set the destination worksheet
    Dim R1 As Long, R2 As Long, C As Long, lRow As Long, lCol As Long 'declare variables to use

    With wsSrc
        lCol = .Cells(1, Columns.Count).End(xlToLeft).Column 'get the last column value in the source sheet, at row 1, will reuse this laster
        Dim arrData_1 As Variant: arrData_1 = .Range(.Cells(1, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 1)) 'declare and allocate the source data to an array
    End With
    With .Sheets("Sheet2")
        Dim arrData_2 As Variant: arrData_2 = .Range("E1:E" & .Cells(Rows.Count, 1).End(xlUp).Row) 'declare and allocate the compare data to an array
    End With
End With

    With wsDst
        For R1 = LBound(arrData_1) To UBound(arrData_1) 'for each row in the source data
            For R2 = LBound(arrData_2) To UBound(arrData_2) 'for each row in the compare data
                If arrData_1(R1, 2) = arrData_2(R2, 1) Then 'if there is a match
                    lRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1 'get the last row in the destination sheet

                    .Range(.Cells(lRow, 1), .Cells(lRow, lCol)).Value = _
                        wsSrc.Range(wsSrc.Cells(R1, 1), wsSrc.Cells(R1, lCol)).Value 'allocate the matching values
                    Exit For 'exit early here if there is a match, go to next row to check
                End If
            Next R2
        Next R1
    End With

Application.ScreenUpdating = True
MsgBox "Done!"

End Sub