Delete rows if value is not mentioned in range

Question

Out of a file with approximately 50.000 rows I want to delete rows which don't have a specific number in column B. I use this code:

Sub DelRows()

Application.ScreenUpdating = False

Worksheets("2016").Activate

lastrow = Cells(Rows.Count, "A").End(xlUp).Row

For i = lastrow To 2 Step -1
If Cells(i, "B").Value <> "1060" And _
Cells(i, "B").Value <> "1061" And _
Cells(i, "B").Value <> "1062" And _
Cells(i, "B").Value <> "1063" And _
Cells(i, "B").Value <> "1064" And _
Cells(i, "B").Value <> "1105" And _
Cells(i, "B").Value <> "11050" And _
Cells(i, "B").Value <> "11051" And _
Cells(i, "B").Value <> "11053" And _
Cells(i, "B").Value <> "11054" And _
Cells(i, "B").Value <> "1160" And _
Cells(i, "B").Value <> "1161" And _
Cells(i, "B").Value <> "1162" And _
Cells(i, "B").Value <> "1163" And _
Cells(i, "B").Value <> "1164" And _
Cells(i, "B").Value <> "1166" And _
Cells(i, "B").Value <> "1168" And _
Cells(i, "B").Value <> "1169" And _
Cells(i, "B").Value <> "8060" And _
Cells(i, "B").Value <> "8061" And _
Cells(i, "B").Value <> "8062" And _
Cells(i, "B").Value <> "8063" And _
Cells(i, "B").Value <> "8064" And _
Cells(i, "B").Value <> "8068" And _
Cells(i, "B").Value <> "8192" Then
Cells(i, "B").EntireRow.Delete
End If

Next i

End Sub

This macro takes a lot of time and it seems to be that there is a maximum of 'and-statements'.

I tried to figure it out with an array or a filter, but it's hard for me as a beginner.

I would like to put the numbers on a separate worksheet as a range e.g.:

I've tried to figure it out with section Criteria range on a different sheet* on https://www.rondebruin.nl/win/winfiles/MoreDeleteCode.txt, but I don't fully understand this VBA code.

Can somebody please help me? Kind regards, Richard

Have you tried implementing that code? How many columns of data do you have? — SJR, Oct 18 '17 at 13:11
To optmize, try to use autofilter with an array multi criteria and delete the rows on a single task. Or if you don't want to use filter, you can make a non contiguous range and delete all at once later. Because the most time consuming action in your code, is every time you perform actions on your worksheet, in your case when you delete. And refer to [this](http://www.cpearson.com/excel/optimize.htm), [this](https://stackoverflow.com/q/30959315/7690982) and [this](https://stackoverflow.com/questions/46077673/improving-a-loop-to-delete-rows-in-excel-faster). — danieltakeshi, Oct 18 '17 at 13:12

score 0 · Answer 1 · answered Oct 18 '17 at 13:21

Let's say the values are as in the code below - rngCheck and rngDelete.

A nested loop can do exactly this job. The outer loop goes through the range, which should be deleted rngDelete and the inner goes through the checking values rngCheck.

If a matching value is found, it is deleted and the inner loop is exited. As far as we are looping through rows and we need to delete some of them, the for loop is with reversed counting:

Option Explicit

Public Sub TestMe()

    Dim cnt         As Long
    Dim rngDelete   As Range
    Dim rngCheck    As Range
    Dim rngCell     As Range

    Set rngCheck = Worksheets(2).Range("A1:A2")
    Set rngDelete = Worksheets(1).Range("A1:A20")

    For cnt = rngDelete.Rows.Count To 1 Step -1
        For Each rngCell In rngCheck
            If rngCell = rngDelete.Cells(cnt, 1) Then
                rngDelete.Rows(cnt).Delete
                Exit For
            End If
        Next rngCell
    Next cnt

End Sub

score 0 · Answer 2 · answered Oct 18 '17 at 13:27

Here's an array approach which saves on reading from and writing to spreadsheets and so should be a bit quicker. This method includes the cells which do match rather than excluding those which don't. Adjust your range of cells against which you are checking accordingly. I have assumed your data start in A1 of sheet 2016.

Sub DelRows()

Dim v, i As Long, j As Long, vOut(), k As Long, rExcl As Range

Set rExcl = Sheets("Sheet2").Range("A1:A5") 'adjust accordingly

With Worksheets("2016")
    v = .Range("A1").CurrentRegion.Value
    .Range("A1").CurrentRegion.Offset(1).ClearContents
    ReDim vOut(1 To UBound(v, 1), 1 To UBound(v, 2))
    For i = LBound(v, 1) To UBound(v, 1)
        If IsNumeric(Application.Match(v(i, 2), rExcl, 0)) Then
            j = j + 1
            For k = LBound(v, 2) To UBound(v, 2)
                vOut(j, k) = v(i, k)
            Next k
        End If
    Next i
    .Range("A2").Resize(j, UBound(v, 2)) = vOut
End With

End Sub

Delete rows if value is not mentioned in range

2 Answers2