Code deletes unique entity that reports data later than 4 quarters, runs too slow

Question

I have a worksheet which is filled with data from Column A to G. Each row is a unique entity and Column G represents how long ago (in quarters) the data was reported. The purpose of the code is to check if the value is more than 4 (that means the reported date was more than 4 quarters from today), and if so, the code would delete that particular row.

Currently my code takes about 3 minutes to run, and I was wondering if there's anything else that I could do/restructure my code for it to run faster.

I have about 5000++ rows as of now.

Sub Two_Keep3Quarters()
    Dim Firstrow As Long
    Dim Lastrow As Long
    Dim lRow As Long
    Dim Tbl As ListObject
    Dim rng As Range
    Dim QuarterValue As Long

    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    With Sheets("Filtered Data")
        .DisplayPageBreaks = False

        'Set the first and last row to loop through
        Firstrow = 3
        Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row

        'We loop from Lastrow to Firstrow (bottom to top)
        For lRow = Lastrow To Firstrow Step -1

        QuarterValue = .Range("G" & lRow).Value

            'We check the values in the Column G
            With .Cells(lRow, "G")

                If Not IsError(QuarterValue) Then

                    If QuarterValue > 4 Then .EntireRow.Delete
                    'This will delete each row with value of more than 4 quarters

                End If

            End With

        Next lRow

    End With

    Range("F1").Value = "Quarters"
    Range("G1").Value = "No. of Quarters"

    On Error Resume Next
    Set rng = Range(Range("A1"), Range("G1").End(xlDown)).SpecialCells(xlCellTypeBlanks)
    rng.Rows.Delete Shift:=xlShiftUp

         For Each Tbl In Sheets("Filtered Data").ListObjects
         Tbl.Unlist

    Next

        Set Tbl = ActiveSheet.ListObjects.Add(xlSrcRange, Range(Range("A1"), Range("G1").End(xlDown)), , xlYes)

    With Tbl
    .Name = "DataTable"
    .TableStyle = "TableStyleLight10"
    End With

Application.ScreenUpdating = True

End Sub

Answer 1

This uses an AutoFilter and performs the delete operation once (it should take less than a sec)

---

Option Explicit

Public Sub Two_Keep3Quarters()
    Const WS_NAME = "Filtered Data"

    Dim ws As Worksheet, tbl As ListObject, tblUR As Range, t As Double

    t = Timer
    Set ws = ThisWorkbook.Worksheets(WS_NAME)
    Set tbl = ws.ListObjects("DataTable")
    Set tblUR = tbl.Range.Offset(2).Resize(tbl.ListRows.Count - 1)

    Application.DisplayAlerts = False
    With tbl.Range
        tblUR.AutoFilter Field:=7, Criteria1:=">4", Operator:=xlAnd
        .Rows("1:2").Hidden = True

        On Error Resume Next    'For empty filter
        tblUR.SpecialCells(xlCellTypeVisible).EntireRow.Delete
        On Error GoTo 0

        .AutoFilter
        .Rows.EntireRow.Hidden = False
        .Cells(1).Activate
    End With
    Application.DisplayAlerts = True
    Debug.Print "Time: " & Format(Timer - t, "0.000") & " sec"
End Sub

---

Some issues with your code:

• Missing Option Explicit
• The Sub should be declared Public explicitly
• Naming conventions: what's the difference between Lastrow and lRow
  • All variable names should start with a lower case letter
• You turn Calculation to xlCalculationManual but don't change it back at the end
• Some ranges are not fully qualified (bellow Range("F1"))
  • When you know the worksheet used you shouldn't qualify ranges with ActiveSheet
• You're performing an extra rng.Rows.Delete which is unneeded
  • When deleting rows make sure you use EntireRow - it's faster
• Tables (ListObjects) are dynamic so there is no need to Unlist and resize them
• Inconsistent indentation (at the end)