How can I delete rows via comparison using VBA?

jmckeone

Well-known Member
Joined
Jun 3, 2006
Messages
550
I have two tabs in a workbook. Each has a column containing a unique numerical identifier. What I want to do is create a macro that will loop through the column on tabA, verify it against the column on tabB and when a match occurs delete the row on tabA. The end result should be that only the new items on tabA will remain. Let me know if this is sufficiently clear or still a bit vague. Thanks.
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
I beleive this snippet of code will do the job:

Code:
Sub ClearDuplicates()
For I = Range("A65536").End(xlUp).Row To 2 Step -1
For J = 2 To Range("A65536").End(xlUp).Row

If Sheets("Sheet1").Cells(I, 1).Value = Sheets("Sheet2").Cells(J, 1).Value Then
    'We have a match
     Sheets("Sheet1").Rows(I).Delete shift:=xlUp
End If

Next
Next
End Sub

Try this out first on sample data before using on production data. Also, it assumes all data is in the first column of both sheets, and ignores the first row.

Take care.

Owen
 
Upvote 0
Tried but ended up getting the following error:

error.jpg
 
Upvote 0
Sheet1 column A are compared to Sheet2 columnA and when a match is found the corresponding row on on Sheet1 should be deleted.
 
Upvote 0
try
Code:
Sub test()
Dim a, e, i As Long, dic As Object, txt As String, r As Range
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
With Sheets("Sheet2")
     a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Value
End With
For Each e In a
     If Not dic.exists(e) Then dic.add e, Nothing
Next
Again:
With Sheets("Sheet1")
     For Each r In .Range("a1",.Range("a" & Rows.Count).End(xlUp))
          If dic.exists(r.Value) Then txt = txt & "," & r.Address(0,0)
          If Len(txt) > 245 Then
               .Range(Mid$(txt,2)).EntireRow.Delete
               txt = "" : GoTo Again
          End If
     Next
     If Len(txt) Then .Range(Mid$(txt,2)).EntireRow.Delete
End With
Set dic = Nothing
End Sub
 
Upvote 0
This should do what you want. If both lists have the same header.
Code:
Sub Macro1()
Dim dataRange As Range, oneArea As Range
Dim removeTheseRange As Range
Dim tempStorage As Variant

With ThisWorkbook.Sheets("sheet2")
    Set removeTheseRange = Range(.Range("a1"), .Cells(.Rows.Count, 1).End(xlUp))
End With

With ThisWorkbook.Sheets("sheet1")
    On Error Resume Next
        .ShowAllData
    On Error GoTo 0
    Set dataRange = Range(.Range("a1"), .Cells(.Rows.Count, 1).End(xlUp))
End With

dataRange.AdvancedFilter Action:=xlFilterInPlace, _
    CriteriaRange:=removeTheseRange, Unique:=False
tempStorage = Range("1:1").Value
Sheets("sheet1").UsedRange.SpecialCell(xlCellTypeVisible).EntireRow.Delete
Rows("1:1").Insert Shift:=xlDown
Rows("1:1").Value = tempStorage
On Error Resume Next
        ThisWorkbook.Sheets("sheet1").ShowAllData
On Error GoTo 0
End Sub
 
Upvote 0
OOps

That line should read

If Not dic.exists(e) Then dic.add e, Nothing

Previous code has been fixed already
 
Upvote 0
Another version with Collection Object:

Code:
Option Base 1

Sub depurar()
Dim colListB As New Collection
Dim lngRowB As Long, lngRowA As Long
Dim i As Long
Dim rngListB As Range, rngListA As Range, rngItemA As Range
Dim arrListB As Variant

With Sheets("Hoja2")
    lngRowB = .Cells(Rows.Count, "A").End(xlUp).Row
        If lngRowB <= 2 Then End
    Set rngListB = .Range("A2:A" & lngRowB)
End With

arrListB = rngListB
ReDim Preserve arrListB(rngListB.Rows.Count, 1)

On Error Resume Next

For i = 1 To UBound(arrListB, 1)
    colListB.Add arrListB(i, 1), CStr(arrListB(i, 1))
Next i
On Error GoTo 0

With Sheets("Hoja1")
    lngRowA = .Cells(Rows.Count, "A").End(xlUp).Row
        If lngRowA <= 1 Then End
    Set rngListA = .Range("A2:A" & lngRowA)
End With

On Error Resume Next

For i = rngListA.Rows.Count To 1 Step -1
colListB.Add rngListA(i).Value, CStr(rngListA(i).Value)
If Err.Number <> 0 Then rngListA(i).EntireRow.Delete

Next i



End Sub
 
Upvote 0

Forum statistics

Threads
1,213,544
Messages
6,114,249
Members
448,556
Latest member
peterhess2002

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top