Excel VBA - Delete rows that do not match list

[gd6noob]

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.

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.

 

[DanteAmor]

If you have your lists in columns A through F on the "Delete List" sheet, assuming like this:

Dante Amor
	A	B	C	D	E	F
1	List1	List2	List3	List4	List5	List6
2	a2	a12	a22	a31	a41	a51
3	a4	a14	a24	a33	a43	a53
4	a6	a16		a35	a45
5	a8			a37
6				a39
Delete List

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

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]

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
	A	B	C	D	E	F	G	H	I	J	K
1	Emplid	Full Name	Internal Email	Change Flag	Effective Date	Location Change Flag	Location Name Previous	Location Name	Dept Change Flag	Department Id Previous	Department Id
2	1289	1234	1324	5/18/1903	2/15/2021	Location Change	2143	1234	1234	7801	7801
3	40696	124	1234	5/18/1903	7/12/2021	Location Change	1324	1234	134	7319	7319
Transfer Data

Test.xlsb
	A	B	C	D	E
1	Dept Change Flag	Location Name	Department Id	Location Name Previous	Effective Date
2		1234	1299010	1234	7/1/2021
3			1299040	1324	7/2/2021
Delete List

 

[DanteAmor]

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]

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]

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:

  '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,

  '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)

  '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:

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]

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
	A	B	C	D	E	F	G	H	I	J	K
1	Emplid	Full Name	Internal Email	Change Flag	Effective Date	Location Change Flag	Location Name Previous	Location Name	Dept Change Flag	Department Id Previous	Department Id
2	1289	1243	143	5/18/1903	7/1/2021	Location Change	1324	1234		7801	1299010
3	40696	3456	546	6/11/1906	7/2/2021	Location Change	5678	1234		7319	1299040
Transfer Data

Test.xlsb
	A	B	C	D
1	Location Name	Department Id	Location Name Previous	Effective Date
2	1234	1299010	1324	7/1/2021
3		1299040	5678	7/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.

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]

Try the following code.
You can add columns on both sheets, the macro will automatically take them and perform the validations.

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