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

Question

I'm trying to compare sheet1 "A" column values to sheet2 "E:E" column values and copy/paste the whole line of every match to sheet3. Please help me to complete this task. I'm very new to VBA.

Thank you very much in advance!

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

Pretty much I rewrote the whole code from scratch. It pretty much uses the initial n2 complexity, but is rather faster than that, because the deletion of the rows in WorkSheet(2) is done in a single last step rangeToDelete.Delete , which saves a lot of time.

Pretty much, the code defines 2 ranges with which is works - ws1Range and ws2Range , using the LastRow function. Once it defines them, it starts looping through them and comparing them. Hence the n2 complexity. In case of equal values, the row is copied and the cell is added to the rangeToDelete .

Note - it will probably not work as "out of the box solution", but try to debug further with F8 and see what happens.

Additionally:

• Using Integer is not a great idea in VBA .
• "_" in the Sub name is used for Events in VBA, thus it is not a great idea to use it. (although it works)
• How to avoid using Select in Excel VBA

Answer 2

Give this a try (see comments in code for more details):

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