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中完成的，这节省了很多时间。

几乎，该代码使用ws1Range函数定义了2个适用的范围-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

尝试一下（有关更多详细信息，请参见代码中的注释）：

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

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

2 个答案: