Delete unmatched rows in Excel

Question

I'm looking to optimize my for loop to search faster. I've turned off ScreenUpdating, EnableEvents, Calculation, and DisplayStatusBar to speed it up a litte. I have about 10,000 rows to search for in the FAR tab. It works by reading the FAR tab rows and if it matches the master account list ("Account_Range") located in the Input tab, it won't delete the row. It will then update the rows (not shown above). I ran this and it took exactly an hour to run.

Sub DeleteRowsWithArray()
Dim dontDelete() As Variant
Dim actRange As range
Set actRange = Sheets("Input").range("Account_Range")
dontDelete = actRange
Dim i As Long, j As Long
Dim isThere As Boolean
Sheets("FAR").Select
For i = Cells(Rows.Count, "B").End(xlUp).Row To 3 Step -1
 For j = LBound(dontDelete) To UBound(dontDelete)
 If StrComp(range("B" & i), dontDelete(j, 1), vbTextCompare) = 0 Then
 isThere = True
 End If
 Next j
 If Not isThere Then
 range("B" & i).Delete shift:=xlUp
 End If
 isThere = False
Next i
End Sub

• PeterT: I suggest building a Dictionary to hold the Range("Account_Range"), then you wouldn't have to loop to find a match, just use .Exists. I suspect the longest process is deleting rows and moving up all the remaining rows.

Answer 1

In your code there are several slow items:

1.

• StrComp(Range("B" & i), dontDelete(j, 1), vbTextCompare) = 0
• I would use Range("B" & i).Value2 = dontDelete(j, 1).Value2

2.

• Like PeterT suggested deleting rows is quite slow, specially when you do it one at the time
• I would hide the rows to keep, and at the end delete all visible rows in one operation

3.

• Another significant performance issue is caused by interacting with the sheet
• You could copy both ranges into 2 separate variants and loop them the same way as ranges

---

Bellow I'm providing a different approach:

• create a new column with a formula that will find all matches from Account_Range
• use AutoFilter to hide the rows you want to keep
• delete all visible rows in one operation

---

Option Explicit
Public Sub DeleteRowsFilter()
 Const FAR_ROW1 As Long = 3
 Dim lrInput As Long, lrFAR As Long, lcFAR As Long, lastCell As Range
 Dim srcRng As String, fCell As Range, formulaRng As Range, t As Double
 FastWB
 t = Timer
 With ThisWorkbook.Worksheets("FAR")
 Set lastCell = GetMaxCell(.UsedRange)
 lrFAR = lastCell.Row
 lcFAR = lastCell.Column
 'create a new column showing if row should be deleted (value = 0) or not (value > 0)
 Set fCell = .Cells(FAR_ROW1, lcFAR + 1)
 fCell.Formula = "=IFERROR(MATCH(B" & FAR_ROW1 & ",Account_Range,0),0)"
 'fill down the formula to last row
 Set formulaRng = .Range(fCell, .Cells(lrFAR, lcFAR + 1))
 fCell.AutoFill Destination:=formulaRng: .Calculate
 'hide the rows to keep
 formulaRng.AutoFilter Field:=1, Criteria1:="=0"
 'delete visible rows (not matching values in Account_Range)
 fCell.Offset(1).Resize(lrFAR - FAR_ROW1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
 .Columns(lcFAR + 1).EntireColumn.Delete 'delet last column (temp formula)
 End With
 Debug.Print "Duration:" & vbTab & Format(Timer - t, "#,##0.0000") & " sec" & vbCrLf
 FastWB False
End Sub

---

In my test file I only used 2 columns on each sheet, both with 10,000 rows
This version deleted more than 6,000 rows

Total Duration: 1.9338 sec

---

I also used 2 helper functions

Turn off visual elements:

Public Sub FastWB(Optional ByVal opt As Boolean = True)
 With Application
 .Calculation = IIf(opt, xlCalculationManual, xlCalculationAutomatic)
 .DisplayAlerts = Not opt
 .DisplayStatusBar = Not opt
 .EnableAnimations = Not opt
 .EnableEvents = Not opt
 .ScreenUpdating = Not opt
 End With
End Sub

---

Determine the last row and column:

Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range
 'Returns the last cell containing a value, or A1 if Worksheet is empty
 Const NONEMPTY As String = "*"
 Dim lRow As Range, lCol As Range
 If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange
 If WorksheetFunction.CountA(rng) = 0 Then
 Set GetMaxCell = rng.Parent.Cells(1, 1)
 Else
 With rng
 Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
 After:=.Cells(1, 1), _
 SearchDirection:=xlPrevious, _
 SearchOrder:=xlByRows)
 If Not lRow Is Nothing Then
 Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
 After:=.Cells(1, 1), _
 SearchDirection:=xlPrevious, _
 SearchOrder:=xlByColumns)
 Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column)
 End If
 End With
 End If
End Function

---