How can I delete 123572 rows faster in VBA?

Question

I have a file with more then 1 sheet, where in the Reports Sheet I want to filter by ASBN products and then delete them, because I already processed it in another sheet, so I need to delete the initial ones in order to paste back the processed one.

Idea is that this deleting code which is working, but is taking for at least 20 minutes, because I want to delete 123 572 rows, do you have any idea how could I make this work faster?

I also tried to clear contents first and then to delete empty rows, but it's the same.

Here you find the code:

Public Sub Remove_ABSN()
    Dim area As String
    Dim start As Long
    
    area = "ABSN"
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    
    start = Worksheets("Reports").Cells(Cells.Rows.Count, 1).End(xlUp).Row
    Worksheets("Reports").Range("$A$2:$AN" & start).AutoFilter Field:=8, Criteria1:=area, Operator:=xlFilterValues
    
    Worksheets("Reports").Range("$A$2:$AN$" & start).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Sheets("Reports").ShowAllData
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.EnableEvents = True
End Sub

Answer 1

I think AutoFilter will be the fastest way to do it. Here are two sample scripts to try. You can see for yourself which one is faster.

Public Sub UnionDeleteRowsFast()

' Careful...delete runs on Sheet1

   Dim sh2 As Worksheet
   Set sh2 = Sheets("Sheet1")
   Dim lastrow As Long
   Dim Rng As Range

   lastrow = Cells(Rows.Count, "B").End(xlUp).Row
   
   For i = lastrow To 2 Step -1
      If Cells(i, 2).Value = "Delete" Then
         If Rng Is Nothing Then
            Set Rng = Range("B" & i)
         Else
            Set Rng = Union(Rng, Range("B" & i))
         End If
      End If
   Next
   If Not Rng Is Nothing Then Rng.EntireRow.Delete
End Sub


Sub AutoFilterDeleteRowsFast()

' Careful...delete runs on ActiveSheet

With ActiveSheet
    .AutoFilterMode = False
    With Range("B4", Range("B" & Rows.Count).End(xlUp))
        .AutoFilter 1, "*Delete*"
        On Error Resume Next
        .Offset(1).SpecialCells(12).EntireRow.Delete
    End With
    .AutoFilterMode = False
End With
End Sub

Answer 2

There is a way that is much faster.

Suppose a table of 100,000 lines (A1:B100001) with headers in line 1. Then delete condition refers to just 1 column (B).

One needs a auxiliar column (A) just to count the lines in the original order. Here I use autofill function.

So one can sort the table and after restore the original order.

Below there is a complete example, that generates randomly numbers from 1 to 10 (it's slow!), and after quickly delete all lines with values 3

Sub EraseValue()
Application.ScreenUpdating = False
Dim i As Long
Dim T1 As Single  ' milisecs after booting (Start)
Dim T2 As Single   ' milisecs after booting (End)
Dim LIni As Variant  ' Initial line to delete
Dim LEnd As Variant  ' Final line to delete

Const Fin = 100000  ' Lines in the table
Const FinStr = "100001"  ' Last line (string)

Randomize (GetTickCount())  ' Seed of random generation
For i = 1 To Fin
   Cells(i + 1, "B") = Int(Rnd() * 10 + 1)  ' Generates from 1 to 10
   If i Mod 100 = 0 Then Application.StatusBar = i
   DoEvents
Next i
Application.StatusBar = False
Dim Table As Range
Dim Colu As Range

T1 = GetTickCount() ' Initial time
Cells(2, "A") = 1  ' Starting value
Cells(3, "A") = 2  ' Step
' Fill from 1 to 100,000 step 1
Range("A2:A3").AutoFill Destination:=Range("A2:A" & FinStr)
' Order by condition column
Table.Sort Key1:=Cells(1, "B"), Header:=xlYes

'One needs delete lines with column B = 3 
'LIni: Search key that not exceed value 2 in the column
' (2 is immediately previous value)
'LEnd: Search key that not exceed value 3 in the column
'LIni and LFim is relative to 2 so add 1 for skip the header
'Add more 1 to Lini in order to get the first value in the column >= key
'
LIni = Application.Match(2, Colu, 1) + 2
LEnd = Application.Match(3, Colu, 1) + 1

If IsError(LIni) Or IsError(LEnd) Or LEnd < LEnd Then
  MsgBox ("There is no lines to delete")
  End
End If

Range(Rows(LIni), Rows(LEnd)).Delete (xlUp)  ' Delete lines
Table.Sort Key1:=Cells(1, "A"), Header:=xlYes ' Restore initial order
  
T2 = GetTickCount() ' Get the final time 
MsgBox ("Elapsed milisecs: " + Format((T2 - T1), "0"))

End Sub

In my old computer, it take a little bit more that 0.5 secs with 100,000 lines.

If one has a condition that involves 2 columns or more, one need to create an another auxiliary column with a formula that concatenate these columns related do desired condition and run the match in this column. The formula needs to usage relative references. For instance (assuming that the data of column C are string and is already filled with a header).

Cells(1,4) = "NewCol"  ' New column D
Dim NewCol As Range
Set NewCol = Range("D2:D" & FinStr)

' Two previous columns concatenated. In line 2
' the formula would be "=Format(B2,"0")+C2" (B2 is a number)
NewCol.FormulaR1C1 = "=Format(RC[-2],"0") & RC[-1]" 
NewCol.Copy                            
NewCol.PasteSpecial(XlValues)   ' Convert all formulas to values
Application.CutCopyMode=false

So one usages the column D instead column B