Excel VBA - Delete rows that do not match list

gd6noob

Board Regular
Joined
Oct 20, 2017
Messages
141
Office Version
  1. 2016
Platform
  1. Windows
Hi guys,

I have a data set that needs some rows deleted if it does not match a list.
I will have 6 lists currently, but it could end up being more in the future.

The list will be on the "Delete List" tab, basically I want to let the user control what data should remain on the "Transfer Data" tab. So anything that is not on the Delete List, then the entire row will be deleted.
This code does this but it seems to take awhile, at least for the initial run, as this removes the bulk of the data. There is usually around 20k+ and this first run should remove around 65-70% of the data.
Then I have 5 more columns on the Delete List and I just repeated the code, adjusting it as I go.

Just wanted to see if there was a more faster/efficient way to code this. I tried using autofilter method bit couldnt get multiple criteria working.

VBA Code:
Dim cfind, cfind1, delete, c As Range
Dim x As String
Dim i, j As Integer
Set td = ThisWorkbook.Worksheets("Transfer Data")
Set dl = ThisWorkbook.Worksheets("Delete List")

Set cfind = dl.Cells.Find(what:="Location Name", lookat:=xlWhole)
Set delete = Range(cfind.Offset(0, 0), cfind.End(xlDown))

    j = td.Range("H2").End(xlDown).Row
    For i = j To 1 Step -1
        x = td.Cells(i, "H").value
Set cfind1 = delete.Find(what:=x, lookat:=xlWhole)
    If cfind1 Is Nothing Then
        td.Cells(i, "H").EntireRow.delete
    End If
Next


Thanks.
 

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,771
Office Version
  1. 2007
Platform
  1. Windows
If you have your lists in columns A through F on the "Delete List" sheet, assuming like this:
Dante Amor
ABCDEF
1List1List2List3List4List5List6
2a2a12a22a31a41a51
3a4a14a24a33a43a53
4a6a16a35a45
5a8a37
6a39
Delete List


The following code processes 30,000 records in 2 seconds.

VBA Code:
Sub DeleteRows()
  Dim sh As Worksheet
  Dim a As Variant, b As Variant
  Dim dic As Object
  Dim i As Long, j As Long, k As Long, m As Long
  
  Set dic = CreateObject("Scripting.Dictionary")
  
  Set sh = Sheets("Transfer Data")
  a = sh.Range("A1", sh.Cells(sh.Range("H" & Rows.Count).End(3).Row, _
                     sh.UsedRange.Columns(sh.UsedRange.Columns.Count).Column)).Value2
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
  
  With Sheets("Delete List")
    'Lists in columns A through F. Starting at row 2
    For j = 1 To 6
      For i = 2 To .Cells(Rows.Count, j).End(3).Row
        dic(.Cells(i, j).Value) = Empty
      Next
    Next
  End With
  
  For i = 2 To UBound(a, 1)
    If dic.exists(a(i, 8)) Then
      k = k + 1
      For m = 1 To UBound(a, 2)
        b(k, m) = a(i, m)
      Next
    End If
  Next
  
  sh.Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
 

gd6noob

Board Regular
Joined
Oct 20, 2017
Messages
141
Office Version
  1. 2016
Platform
  1. Windows
Hi @DanteAmor, thank you for replying.

I tried this code and it works if the Delete List doesnt have too many columns.. or maybe Im not understanding.

I will include both sheets as sample.

Test.xlsb
ABCDEFGHIJK
1EmplidFull NameInternal EmailChange FlagEffective DateLocation Change FlagLocation Name PreviousLocation NameDept Change FlagDepartment Id PreviousDepartment Id
21289123413245/18/19032/15/2021Location Change21431234123478017801
34069612412345/18/19037/12/2021Location Change1324123413473197319
Transfer Data


Test.xlsb
ABCDE
1Dept Change FlagLocation NameDepartment IdLocation Name PreviousEffective Date
2 1234129901012347/1/2021
3129904013247/2/2021
Delete List
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,771
Office Version
  1. 2007
Platform
  1. Windows
Could you explain it.
Now that you put an example, which I consider is very small.
If that's what I'm thinking. All the records in your example will be deleted.

But I am not going to anticipate making conjectures, it better explains what the macro should do with the columns of the "Delete List" sheet, that is, what to do with the coumna with the name "Dept Change Flag", what to do with the column "Location Name", what to do with column "Department Id"....

Try to be explicit with your explanation, because maybe it is very obvious for you, because you know your data, but for us it is so no obvious.

I'm going to venture. If I delete data from "Transfer Data" considering the column "Location Name" (B with H), it does not delete records from your example.
If I perform the data deletion of "Transfer Data" considering the column "Department Id" (C with K), delete all the records of your example.

Is my assumption correct?
This is how the macro should work?
 

gd6noob

Board Regular
Joined
Oct 20, 2017
Messages
141
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

My bad for not being more clear.

What I'm looking for is on the Delete List tab (perhaps this should be rename to something else) for each column, represents on the same columns on the Transfer Data tab. Whatever is on the Delete List, should remain and everything else gets delete.

For example, I want to start with Column B on the Delete List, any value not on this list, the rows should be deleted. Then go to Column C on the Delete list, and so on.
You can think of it as the order of completion on the Delete list should be starting with Column B and to end of columns. Also it could be more columns added, so it may not end at column E.

I hope this is more clear.

Thank you.
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,771
Office Version
  1. 2007
Platform
  1. Windows
What matters and what you have not mentioned, is that column A of your "delete list" sheet against which column to compare.
For the example that I put the pairs of columns are like this:

VBA Code:
  'columns       A  B  C   D  E   'delete list sheet
  'vs columns    I  H  K   G  E   'transfer data sheet

It is necessary to start in column A of the sheet "delete list". If you don't require column A, just leave it empty, just like you put it in your example.
As you will notice, I mention and mention the example, it would be easier to understand if you explained your requirement with the example.
But let's see if I can understand it.

In the following arrangement you must put the column you want to add,
VBA Code:
  'columns       A  B  C   D  E   'delete list sheet
  'vs columns    I  H  K   G  E   'transfer data sheet
  arr = Array(0, 9, 8, 11, 7, 5)

for example if you put a new list in column F, then, You add the number of column X, it means that the sixth column (F) is going to be compared against column 24 (x)
VBA Code:
  'columns       A  B  C   D  E  F  'delete list sheet
  'vs columns    I  H  K   G  E  X 'transfer data sheet
  arr = Array(0, 9, 8, 11, 7, 5, 24)

Try this:
VBA Code:
Sub DeleteRows()
  Dim sh As Worksheet
  Dim a As Variant, b As Variant, arr As Variant
  Dim dic As Object, existe As Boolean
  Dim i As Long, j As Long, k As Long, m As Long, lr As Long, lb As Long
  
  'columns       A  B  C   D  E   'delete list sheet
  'vs columns    I  H  K   G  E   'transfer data sheet
  arr = Array(0, 9, 8, 11, 7, 5)
  Set dic = CreateObject("Scripting.Dictionary")
  
  Set sh = Sheets("Transfer Data")
  a = sh.Range("A1:K" & sh.Range("H" & Rows.Count).End(3).Row).Value2
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
  With Sheets("Delete List")
    For j = 1 To UBound(arr)
      lr = .Cells(Rows.Count, j).End(3).Row
      If lr > 1 Then
        For i = 2 To lr
          dic(j & "|" & .Cells(i, j).Value) = Empty
        Next
      End If
    Next
  End With
  
  For i = 2 To UBound(b, 1)
    existe = True
    For j = 1 To UBound(arr)
      If Not dic.exists(j & "|" & a(i, arr(j))) Then
        existe = False
        Exit For
      End If
    Next
    If existe Then
      k = k + 1
      For m = 1 To UBound(a, 2)
        b(k, m) = a(i, m)
      Next
    End If
  Next
  
  sh.Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
 

gd6noob

Board Regular
Joined
Oct 20, 2017
Messages
141
Office Version
  1. 2016
Platform
  1. Windows
Im sorry, I must not be getting this right.. for some reason, it just clears my entire data on the Transfer Data, but it was super quick.

Let me try to explain again from the beginning and I also updated: Delete List > Keep List, removed Dept Change Flag from the Keep List

Basically, each column on the Keep List would stay on the Transfer Data tab.

i.e.
  1. Starting with Column A on the Keep List
  2. Location Name (column A on Keep tab), the value from row 2+ would refer to Column H (on the Transfer Data) and any value in here that does not match, the entire row should be deleted.
  3. This should remove the bulk of the entries in the Transfer Data tab. Then delete more rows using the next column on the Keep List.
  4. Department Id (column B on Keep tab), the value from row 2+ would refer to Column K (on the Transfer Data) and any value in here that does not match, the entire row should be deleted.
  5. After this, move onto the next column on the Keep List
  6. Location Name Previous (column C on Keep tab), the value from row 2+ would refer to Column G (on the Transfer Data) and any value in here that does not match, the entire row should be deleted.
  7. After this, move onto the next column on the Keep List
  8. Effective Date (column D on Keep tab), the value from row 2+ would refer to Column E (on the Transfer Data) and any value in here that does not match, the entire row should be deleted.
  9. There could be more columns added later on.

Test.xlsb
ABCDEFGHIJK
1EmplidFull NameInternal EmailChange FlagEffective DateLocation Change FlagLocation Name PreviousLocation NameDept Change FlagDepartment Id PreviousDepartment Id
2128912431435/18/19037/1/2021Location Change13241234 78011299010
34069634565466/11/19067/2/2021Location Change56781234 73191299040
Transfer Data


Test.xlsb
ABCD
1Location NameDepartment IdLocation Name PreviousEffective Date
21234129901013247/1/2021
3129904056787/2/2021
Keep List



The code I shared on the first post, I had set it to find the header value and then find the matching header value in the Transfer Data tab and then deletes rows that do not match the list under the corresponding list. I have included my code that I was using.

VBA Code:
sub testing()
Dim cfind, cfind1, delete, c As Range
Dim x As String
Dim i, j As Integer
Set td = ThisWorkbook.Worksheets("Transfer Data")
Set dl = ThisWorkbook.Worksheets("Keep List")

Set cfind = dl.Cells.Find(what:="Location Name", lookat:=xlWhole)
Set delete = Range(cfind.Offset(0, 0), cfind.End(xlDown))

j = td.Range("H2").End(xlDown).Row
For i = j To 1 Step -1
x = td.Cells(i, "H").value
Set cfind1 = delete.Find(what:=x, lookat:=xlWhole)
If cfind1 Is Nothing Then
td.Cells(i, "H").EntireRow.delete
End If
Next

Set cfind = dl.Cells.Find(what:="Department Id", lookat:=xlWhole)
Set delete = Range(cfind.Offset(0, 0), cfind.End(xlDown))

j = td.Range("K2").End(xlDown).Row
For i = j To 1 Step -1
x = td.Cells(i, "K").value
Set cfind1 = delete.Find(what:=x, lookat:=xlWhole)
If cfind1 Is Nothing Then
td.Cells(i, "K").EntireRow.delete
End If
Next

Set cfind = dl.Cells.Find(what:="Location Name Previous", lookat:=xlWhole)
Set delete = Range(cfind.Offset(0, 0), cfind.End(xlDown))

j = td.Range("G2").End(xlDown).Row
For i = j To 1 Step -1
x = td.Cells(i, "G").value
Set cfind1 = delete.Find(what:=x, lookat:=xlWhole)
If cfind1 Is Nothing Then
td.Cells(i, "G").EntireRow.delete
End If
Next

Set cfind = dl.Cells.Find(what:="Effective Date", lookat:=xlWhole)
Set delete = Range(cfind.Offset(0, 0), cfind.End(xlDown))

j = td.Range("E2").End(xlDown).Row
For i = j To 1 Step -1
x = td.Cells(i, "E").value
Set cfind1 = delete.Find(what:=x, lookat:=xlWhole)
If cfind1 Is Nothing Then
td.Cells(i, "E").EntireRow.delete
End If
Next

end sub
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,771
Office Version
  1. 2007
Platform
  1. Windows
Try the following code.
You can add columns on both sheets, the macro will automatically take them and perform the validations.

VBA Code:
Sub DeleteRows()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim a As Variant, b As Variant, arr As Variant, ar2 As Variant
  Dim dic As Object, existe As Boolean
  Dim i As Long, j As Long, k As Long, m As Long, n As Long, lr As Long, lc As Long
  Dim f As Range
  
  Set sh1 = Sheets("Transfer Data")
  Set sh2 = Sheets("Keep List")
  Set dic = CreateObject("Scripting.Dictionary")
  
  arr = sh2.Range("A1", sh2.Cells(1, Columns.Count).End(1))
  ReDim ar2(1 To UBound(arr, 2), 1 To 2)
  For j = 1 To UBound(arr, 2)
    lr = sh2.Cells(Rows.Count, j).End(3).Row
    If lr > 1 Then
      Set f = sh1.Rows(1).Find(arr(1, j), , xlValues, xlWhole, , , False)
      If Not f Is Nothing Then
        n = n + 1
        ar2(n, 1) = arr(1, j)
        ar2(n, 2) = f.Column
        For i = 2 To lr
          dic(f.Column & "|" & sh2.Cells(i, j).Value) = Empty
        Next
      End If
    End If
  Next
  lc = sh1.Cells(1, Columns.Count).End(1).Column
  a = sh1.Range("A1", sh1.Cells(sh1.Range("H" & Rows.Count).End(3).Row, lc)).Value2
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))

  For i = 2 To UBound(a, 1)
    existe = True
    For n = 1 To UBound(ar2, 1)
      If Not dic.exists(ar2(n, 2) & "|" & a(i, ar2(n, 2))) Then
        existe = False
        Exit For
      End If
    Next
    If existe Then
      k = k + 1
      For m = 1 To UBound(a, 2)
        b(k, m) = a(i, m)
      Next
    End If
  Next
  
  sh1.Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
 

Forum statistics

Threads
1,144,366
Messages
5,723,942
Members
422,527
Latest member
TotalBeginner201

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
Top