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 и посмотрите, что произойдет.

Дополнительно:

• Использование Integer не очень хорошая идея в VBA .
• "_" в имени Sub используется для событий в VBA, поэтому его не рекомендуется использовать. (хотя это работает)
• Как избежать использования Select в 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