trjhtr

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

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)