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
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 –
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
Note – it will probably not work as “out of the box solution”, but try to debug further with F8 and see what happens.
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