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復雜度，但是比起最初的n2復雜度要快得多，因為刪除WorkSheet(2)中的行是在最后一個步驟rangeToDelete.Delete ，這節省了很多時間。

幾乎，代碼使用LastRow函數定義了2個適用的范圍ws1Range和ws2Range 。 一旦定義了它們，便開始遍歷它們並進行比較。 因此， n2復雜度。 如果值相等，則復制該行，並將該單元格添加到rangeToDelete 。

注意-它可能無法作為“開箱即用的解決方案”工作，但是嘗試使用F8進行進一步調試，看看會發生什么。

另外：

• 在VBA中，使用Integer不是一個好主意 。
• Sub名稱中的“ _”用於VBA中的“事件”，因此使用它不是一個好主意。 （盡管有效）
• 如何避免在Excel VBA中使用選擇

Answer 2

嘗試一下（有關更多詳細信息，請參見代碼中的注釋）：

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