Excel VBA code to delete rows that do not match a separate list

[NathanA]

I am using VBA code in Excel 2016 to delete rows (on sheet "Data") that don't match criteria on another sheet (Column A, on sheet "Unique values") in Excel. However, the code only deletes selected cells in one column (C), so the remaining cells then don't match the original data in other columns (A:BH).

Could someone help to modify the code so that the entire row is deleted, and the rows move up/down together? I have tried code from a similar thread, but it didn't delete the correct rows, whereas this code does, and the portion of the code to select the list is very helpful as this list can be moved.

Any guidance is much appreciated.

Sub DeleteRowsThatDoNotMatch()
Dim rng As Range
Dim Rng1 As Range, Rng2 As Range
Dim arr1 As Variant
Dim arr2 As Variant
Dim dic2 As Variant
Dim OutArr As Variant
xTitleId = "Delete Row"
Set Rng1 = Application.Selection
Set Rng1 = Application.InputBox("Select data to delete :", xTitleId, Rng1.Address, Type:=8)
Set Rng2 = Application.InputBox("Select unique values:", xTitleId, Type:=8)
Set Rng1 = Rng1.Columns(1)
Set Rng2 = Rng2.Columns(1)
Set dic2 = CreateObject("Scripting.Dictionary")
arr1 = Rng1.Value
arr2 = Rng2.Value
For i = 1 To UBound(arr2, 1)
    xKey = arr2(i, 1)
    dic2(xKey) = ""
Next
Rng1.ClearContents
OutArr = Rng1.Value
xIndex = 1
For i = 1 To UBound(arr1, 1)
    xKey = arr1(i, 1)
    If dic2.Exists(xKey) Then
        OutArr(xIndex, 1) = xKey
        xIndex = xIndex + 1
    End If
Next
Rng1.Value = OutArr
End Sub

 

[Joe4]

Haven't really used the method you are using to delete records, but where exactly in your code is the row deletion happening?
Note that this line here:

Rng1.ClearContents

does not delete a row, it simply blanks out the contents of the row, leaving the row where it is.
If you had wanted to physically delete that row, you would use a line like this:

Rng1.EntireRow.Delete

 

[NathanA]

Thanks for explaining difference. Unfortunately when I changed that part of my code, every row was deleted, not just the ones that didn't match the list.
Would you know how to change that?

 

[Joe4]

Unfortunately, as I mentioned, you are using a method that I haven't used, so I really cannot say.
I saw that you post hadn't had any replies, and I noticed you were trying to delete records, but do not see any delete commands in your code. So I took a shot in the dark.

 

[wideboydixon]

Not easy using the approach above. This is based on the original solution:

Sub DeleteRowsThatDoNotMatch()

Dim rng As Range
Dim Rng1 As Range, Rng2 As Range
Dim thisRow As Long
Dim arr1 As Variant
Dim arr2 As Variant
Dim dic2 As Variant
Dim OutArr As Variant

xTitleId = "Delete Row"
Set Rng1 = Application.Selection
Set Rng1 = Application.InputBox("Select data to delete :", xTitleId, Rng1.Address, Type:=8)
Set Rng2 = Application.InputBox("Select unique values:", xTitleId, Type:=8)
Set Rng1 = Rng1.Columns(1)
Set Rng2 = Rng2.Columns(1)
Set dic2 = CreateObject("Scripting.Dictionary")
arr2 = Rng2.Value
For i = 1 To UBound(arr2, 1)
    xKey = arr2(i, 1)
    dic2(xKey) = ""
Next

thisRow = Rng1.Rows.Count
Do While thisRow > 0
    If Not dic2.exists(Rng1.Cells(thisRow, 1).Value) Then
        Rng1.Cells(thisRow, 1).EntireRow.Delete
    End If
    thisRow = thisRow - 1
Loop

End Sub

WBD

 

[NathanA]

Thanks for your reply. I have tried using the code but Excel doesn't respond. Is there another approach to reach the same outcome? i.e. if cell A in row 1 and row 3 contain "chosen word", delete rows 1 and 3 so the original rows 2 and 4 become new rows 1 and 2.

 

[wideboydixon]

I just ran the code and it's working as expected. What is the size of the two data sets your working with?

WBD

 

[NathanA]

I've run it with a smaller set of data and it works perfectly, thanks!