VBA: Delete row if not match list

G

gd6noob

Board Regular
Joined
Oct 20, 2017
Messages
170
Office Version
  1. 2016
Platform
  1. Windows
Hope everyone is well.

I have a workbook that has 2 sheets.
Sheet1 will have rows delete if Column A is not found on Sheet2 Column A. Sheet2 has around 15-20 criteria's
I tried using Autofilter but it takes some time to complete. My data is anywhere from 60k-100k rows and generally half of that needs to be deleted.

Is there a more efficient way to go about this?

Regards,
gd6noob
 

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.
Sort by date Sort by votes
Hi gd6noob,

Try this (initially on a copy of your workbook as the results cannot be undone if they're not as expected):

VBA Code: 
Option Explicit
Sub Macro1()

    'https://www.mrexcel.com/board/threads/vba-delete-row-if-not-match-list.1206925
    'Delete row from Sheet1 Col. A if the entry is not in Col. A of Sheet2

    Dim lngRowFrom As Long
    Dim objCriteria As Object
    Dim rngCell As Range, rngDelRows As Range
    
    Application.ScreenUpdating = False
    
    lngRowFrom = 2 'Starting row for Sheet1 and Sheet2. Change to suit if necessary.

    Set objCriteria = CreateObject("Scripting.Dictionary")
    
    For Each rngCell In Sheet2.Range("A" & lngRowFrom & ":A" & Sheet2.Range("A" & Rows.Count).End(xlUp).Row)
        If Len(rngCell) > 0 Then
            If objCriteria.Exists(CStr(StrConv(rngCell.Value, vbUpperCase))) = False Then
                objCriteria.Add CStr(StrConv(rngCell.Value, vbUpperCase)), rngCell.Row
            End If
        End If
    Next rngCell
    
    For Each rngCell In Sheet1.Range("A" & lngRowFrom & ":A" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row)
        If objCriteria.Exists(CStr(StrConv(rngCell.Value, vbUpperCase))) = False Then
            If rngDelRows Is Nothing Then
                Set rngDelRows = Sheet1.Rows(rngCell.Row)
            Else
                Set rngDelRows = Union(rngDelRows, Sheet1.Rows(rngCell.Row))
            End If
        End If
    Next rngCell
    
    Set objCriteria = Nothing
    
    If Not rngDelRows Is Nothing Then
        rngDelRows.EntireRow.Delete
        MsgBox "All items in Col. A of Sheet1 that were not in Col. A of Sheet2 have now been deleted.", vbInformation
    Else
        MsgBox "There were no records found in Col. A of Sheet1 that were not in Col. of Sheet2.", vbInformation
    End If
    
    Application.ScreenUpdating = True
        
End Sub

Regards,

Robert
 
Upvote 0
Trebor76 said:
Hi gd6noob,

Try this (initially on a copy of your workbook as the results cannot be undone if they're not as expected):

VBA Code: 
Option Explicit
Sub Macro1()

    'https://www.mrexcel.com/board/threads/vba-delete-row-if-not-match-list.1206925
    'Delete row from Sheet1 Col. A if the entry is not in Col. A of Sheet2

    Dim lngRowFrom As Long
    Dim objCriteria As Object
    Dim rngCell As Range, rngDelRows As Range
   
    Application.ScreenUpdating = False
   
    lngRowFrom = 2 'Starting row for Sheet1 and Sheet2. Change to suit if necessary.

    Set objCriteria = CreateObject("Scripting.Dictionary")
   
    For Each rngCell In Sheet2.Range("A" & lngRowFrom & ":A" & Sheet2.Range("A" & Rows.Count).End(xlUp).Row)
        If Len(rngCell) > 0 Then
            If objCriteria.Exists(CStr(StrConv(rngCell.Value, vbUpperCase))) = False Then
                objCriteria.Add CStr(StrConv(rngCell.Value, vbUpperCase)), rngCell.Row
            End If
        End If
    Next rngCell
   
    For Each rngCell In Sheet1.Range("A" & lngRowFrom & ":A" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row)
        If objCriteria.Exists(CStr(StrConv(rngCell.Value, vbUpperCase))) = False Then
            If rngDelRows Is Nothing Then
                Set rngDelRows = Sheet1.Rows(rngCell.Row)
            Else
                Set rngDelRows = Union(rngDelRows, Sheet1.Rows(rngCell.Row))
            End If
        End If
    Next rngCell
   
    Set objCriteria = Nothing
   
    If Not rngDelRows Is Nothing Then
        rngDelRows.EntireRow.Delete
        MsgBox "All items in Col. A of Sheet1 that were not in Col. A of Sheet2 have now been deleted.", vbInformation
    Else
        MsgBox "There were no records found in Col. A of Sheet1 that were not in Col. of Sheet2.", vbInformation
    End If
   
    Application.ScreenUpdating = True
       
End Sub

Regards,

Robert
Click to expand...
Thanks for the quick response.
I don't know if it's just me but when I ran this on my large dataset, it seems to just crash my workbook.
 
Upvote 0
I don't know if it's just me but when I ran this on my large dataset, it seems to just crash my workbook.
Click to expand...

That's odd as it worked for me :confused:

I did reference the tabs using their assumed code names so maybe that's issue so see how this goes:

VBA Code: 
Option Explicit
Sub Macro1()

    'https://www.mrexcel.com/board/threads/vba-delete-row-if-not-match-list.1206925
    'Delete row from Sheet1 Col. A if the entry is not in Col. A of Sheet2

    Dim lngRowFrom As Long
    Dim objCriteria As Object
    Dim rngCell As Range, rngDelRows As Range
    
    Application.ScreenUpdating = False
    
    lngRowFrom = 2 'Starting row for Sheet1 and Sheet2. Change to suit if necessary.

    Set objCriteria = CreateObject("Scripting.Dictionary")
    
    For Each rngCell In Sheets("Sheet2").Range("A" & lngRowFrom & ":A" & Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row)
        If Len(rngCell) > 0 Then
            If objCriteria.Exists(CStr(StrConv(rngCell.Value, vbUpperCase))) = False Then
                objCriteria.Add CStr(StrConv(rngCell.Value, vbUpperCase)), rngCell.Row
            End If
        End If
    Next rngCell
    
    For Each rngCell In Sheets("Sheet1").Range("A" & lngRowFrom & ":A" & Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row)
        If objCriteria.Exists(CStr(StrConv(rngCell.Value, vbUpperCase))) = False Then
            If rngDelRows Is Nothing Then
                Set rngDelRows = Sheet1.Rows(rngCell.Row)
            Else
                Set rngDelRows = Union(rngDelRows, Sheets("Sheet1").Rows(rngCell.Row))
            End If
        End If
    Next rngCell
    
    Set objCriteria = Nothing
    
    Application.ScreenUpdating = True
    
    If Not rngDelRows Is Nothing Then
        rngDelRows.EntireRow.Delete
        MsgBox "All items in Col. A of Sheet1 that were not in Col. A of Sheet2 have now been deleted.", vbInformation
    Else
        MsgBox "There were no records found in Col. A of Sheet1 that were not in Col. of Sheet2.", vbInformation
    End If
    
End Sub
 
Upvote 0
Another option?

VBA Code: 
Option Explicit
Sub gd6noob()
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    
    Dim lr As Long, lc As Long, i As Long, j As Long
    lr = ws1.Cells(Rows.Count, 1).End(3).Row
    lc = ws1.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    
    Dim arr
    arr = ws2.Range("A2", ws2.Cells(Rows.Count, "A").End(xlUp))
    arr = Application.Transpose(Application.Index(arr, 0, 1))
    
    With ws1.Range("A1")
        .AutoFilter 1, Array(arr), 7
        ws1.Range(ws1.Cells(2, lc), ws1.Cells(lr, lc)).SpecialCells(12).Value = 1
        .AutoFilter
    End With
    
    ws1.Range(ws1.Cells(2, 1), ws1.Cells(lr, lc)).Sort Key1:=ws1.Cells(2, lc), order1:=1, Header:=2
    
    i = WorksheetFunction.Sum(Columns(lc))
    j = i + 2
    
    If i > 0 Then ws1.Range("A" & j & ":A" & lr).EntireRow.Delete
    ws1.Columns(lc).ClearContents
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic
End Sub
 
Upvote 0
Another one to test with a copy of your workbook.
I have assumed that both sheets have a header row with actual data starting on row 2.

VBA Code: 
Sub Del_Rws()
  Dim d As Object
  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, k As Long
 
  Set d = CreateObject("Scripting.Dictionary")
  With Sheets("Sheet2")
    a = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value
  End With
  For i = 1 To UBound(a)
    d(a(i, 1)) = 1
  Next i
  With Sheets("Sheet1")
    nc = .Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    a = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
      If Not d.exists(a(i, 1)) Then
        b(i, 1) = 1
        k = k + 1
      End If
    Next i
    If k > 0 Then
      Application.ScreenUpdating = False
      With .Range("A2").Resize(UBound(a), nc)
        .Columns(nc).Value = b
        .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
        .Resize(k).EntireRow.Delete
      End With
      Application.ScreenUpdating = True
    End If
  End With
End Sub
 
Upvote 0
Solution
Trebor76 said:
That's odd as it worked for me :confused:

I did reference the tabs using their assumed code names so maybe that's issue so see how this goes:

VBA Code: 
Option Explicit
Sub Macro1()

    'https://www.mrexcel.com/board/threads/vba-delete-row-if-not-match-list.1206925
    'Delete row from Sheet1 Col. A if the entry is not in Col. A of Sheet2

    Dim lngRowFrom As Long
    Dim objCriteria As Object
    Dim rngCell As Range, rngDelRows As Range
  
    Application.ScreenUpdating = False
  
    lngRowFrom = 2 'Starting row for Sheet1 and Sheet2. Change to suit if necessary.

    Set objCriteria = CreateObject("Scripting.Dictionary")
  
    For Each rngCell In Sheets("Sheet2").Range("A" & lngRowFrom & ":A" & Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row)
        If Len(rngCell) > 0 Then
            If objCriteria.Exists(CStr(StrConv(rngCell.Value, vbUpperCase))) = False Then
                objCriteria.Add CStr(StrConv(rngCell.Value, vbUpperCase)), rngCell.Row
            End If
        End If
    Next rngCell
  
    For Each rngCell In Sheets("Sheet1").Range("A" & lngRowFrom & ":A" & Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row)
        If objCriteria.Exists(CStr(StrConv(rngCell.Value, vbUpperCase))) = False Then
            If rngDelRows Is Nothing Then
                Set rngDelRows = Sheet1.Rows(rngCell.Row)
            Else
                Set rngDelRows = Union(rngDelRows, Sheets("Sheet1").Rows(rngCell.Row))
            End If
        End If
    Next rngCell
  
    Set objCriteria = Nothing
  
    Application.ScreenUpdating = True
  
    If Not rngDelRows Is Nothing Then
        rngDelRows.EntireRow.Delete
        MsgBox "All items in Col. A of Sheet1 that were not in Col. A of Sheet2 have now been deleted.", vbInformation
    Else
        MsgBox "There were no records found in Col. A of Sheet1 that were not in Col. of Sheet2.", vbInformation
    End If
  
End Sub
Click to expand...
I was able to finally get it work, my initial dataset had about 60k rows which didnt work, then I reduced it to 30k and same problem. Reduced it down to 15k rows and it worked. took about a min and a half. Perhaps there is a limit on how much data it can handle?
Thank you for the help.
 
Last edited:
Upvote 0
kevin9999 said:
Another option?

VBA Code: 
Option Explicit
Sub gd6noob()
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
   
    Dim lr As Long, lc As Long, i As Long, j As Long
    lr = ws1.Cells(Rows.Count, 1).End(3).Row
    lc = ws1.Cells(1, Columns.Count).End(xlToLeft).Column + 1
   
    Dim arr
    arr = ws2.Range("A2", ws2.Cells(Rows.Count, "A").End(xlUp))
    arr = Application.Transpose(Application.Index(arr, 0, 1))
   
    With ws1.Range("A1")
        .AutoFilter 1, Array(arr), 7
        ws1.Range(ws1.Cells(2, lc), ws1.Cells(lr, lc)).SpecialCells(12).Value = 1
        .AutoFilter
    End With
   
    ws1.Range(ws1.Cells(2, 1), ws1.Cells(lr, lc)).Sort Key1:=ws1.Cells(2, lc), order1:=1, Header:=2
   
    i = WorksheetFunction.Sum(Columns(lc))
    j = i + 2
   
    If i > 0 Then ws1.Range("A" & j & ":A" & lr).EntireRow.Delete
    ws1.Columns(lc).ClearContents
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic
End Sub
Click to expand...

Peter_SSs said:
Another one to test with a copy of your workbook.
I have assumed that both sheets have a header row with actual data starting on row 2.

VBA Code: 
Sub Del_Rws()
  Dim d As Object
  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, k As Long
 
  Set d = CreateObject("Scripting.Dictionary")
  With Sheets("Sheet2")
    a = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value
  End With
  For i = 1 To UBound(a)
    d(a(i, 1)) = 1
  Next i
  With Sheets("Sheet1")
    nc = .Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    a = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
      If Not d.exists(a(i, 1)) Then
        b(i, 1) = 1
        k = k + 1
      End If
    Next i
    If k > 0 Then
      Application.ScreenUpdating = False
      With .Range("A2").Resize(UBound(a), nc)
        .Columns(nc).Value = b
        .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
        .Resize(k).EntireRow.Delete
      End With
      Application.ScreenUpdating = True
    End If
  End With
End Sub
Click to expand...
Thanks, both these worked.
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Solved
Find #REF! errors in multiple tables and delete those rows
Replies
7
Views
258
Peter_SSs
Peter_SSs
R
  • Question Question
VBA for Cut, move, paste, delete rows
Replies
6
Views
75
RForster6
R
K
  • Solved
Mysmatch loop VBA for deleting empty rows in a table
Replies
7
Views
154
dreid1011
dreid1011
M
  • Question Question
Delete rows that doe not match
Replies
1
Views
235
Joe4
Joe4
C
  • Question Question
Lookup whole rows from one sheet in another sheet?
Replies
1
Views
546
offthelip
O

Forum statistics

Threads
1,223,532
Messages
6,172,878
Members
452,486
Latest member
standw01

Share this page

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