Code deletes unique entity that reports data later than 4 quarters, runs too slow 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" &amp; lRow).Value

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

                If Not IsError(QuarterValue) Then

                    If QuarterValue &gt; 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
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:="&gt;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: " &amp; Format(Timer - t, "0.000") &amp; " 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)