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