Speeding up For Loop which contains calculations - excel

Question

Changed code to this (entire module is here)
Sub Filter_TPDrop()
'
' Filter based on Voids and < 5 min times
'
Dim LstRow, i, TestVoid, TestTime As Long
Dim ActiveDate As Variant
Dim NewData, delRange As Range
Dim T1, T2 As Date
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
ActiveDate = Worksheets("TPDrop").Range("H2").Value
'
' Sort the Table by location and cheque open time
Worksheets("TPDrop").Range("A1").Sort _
Key1:=Worksheets("TPDrop").Columns("A"), Header:=xlYes, _
Key2:=Worksheets("TPDRop").Columns("I"), Header:=xlYes
Worksheets("TPDrop").Range("A1").Select
' Find last row of Data
With ActiveSheet.UsedRange
LstRow = .Rows(.Rows.Count).Row
End With
' Delete Any Row where K,L and M = 0 (Void) and where chqtime , 5 min
For i = 2 To LstRow
TestVoid = (Range("K" & i).Value + Range("L" & i).Value + Range("M" & i).Value)
T1 = (Range("I" & i).Value)
T2 = (Range("J" & i).Value)
TestTime = DateDiff("n", T1, T2)
If TestVoid = 0 Or TestTime < 5 Then
Set delRange = Rows(i)
Else
Set delRange = Union(delRange, Rows(i))
End If
Next i
If Not delRange Is Nothing Then delRange.Delete shift:=xlUp
' reset LstRow after filtering and put line between locations
With ActiveSheet.UsedRange
LstRow = .Rows(.Rows.Count).Row
End With
Set NewData = ActiveSheet.UsedRange
For i = LstRow To 3 Step -1
If NewData.Cells(i, 1).Value <> NewData.Cells(i - 1, 1).Value Then
NewData.Cells(i, 1).EntireRow.Insert
End If
Next i
'
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
This snippet of code works but is taking about 4 minutes to run through 6400 lines. I'm not familiar with arrays but
understand through reading other posts that using them could greatly speed up this section of code. Anyone have any
suggestions?
Sub Filter_TPDrop()
'
' Filter based on Voids and < 5 min times
'
Dim LstRow, i, TestVoid, TestTime As Long
Dim ActiveDate As Variant
Dim NewData As Range
Dim T1, T2 As Date
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
ActiveDate = Worksheets("TPDrop").Range("H2").Value
'
' Sort the Table by location and cheque open time
Worksheets("TPDrop").Range("A1").Sort _
Key1:=Worksheets("TPDrop").Columns("A"), Header:=xlYes, _
Key2:=Worksheets("TPDRop").Columns("I"), Header:=xlYes
Worksheets("TPDrop").Range("A1").Select
' Find last row of Data
With ActiveSheet.UsedRange
LstRow = .Rows(.Rows.Count).Row
End With
' Delete Any Row where K,L and M = 0 (Void) and where chqtime < 5 min
For i = LstRow To 2 Step -1
TestVoid = (Range("K" & i).Value + Range("L" & i).Value _
+ Range("M" & i).Value)
T1 = (Range("I" & i).Value)
T2 = (Range("J" & i).Value)
TestTime = DateDiff("n", T1, T2)
If TestVoid = 0 _
Or TestTime < 5 _
Then Rows(i).Delete
Next i
End Sub

Answer 1

You are deleting in a loop. See my Answer which does the deletion in the end and not in the loop ;) This will greatly increase your speed.
Change For i = LstRow To 2 Step -1 to For i = 2 To LstRow
and replace
If TestVoid = 0 _
Or TestTime < 5 _
Then Rows(i).Delete
by
If TestVoid = 0 Or TestTime < 5 Then
If delRange Is Nothing Then
Set delRange = .Rows(i)
Else
Set delRange = Union(delRange, .Rows(i))
End If
End If
And after Next i, put this line
If Not delRange Is Nothing Then delRange.Delete shift:=xlUp