2
\$\begingroup\$

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
\$\endgroup\$
1
\$\begingroup\$

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)
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.