Code deletes unique entity that reports data later than 4 quarters, runs too slow
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)