Speeding up For Loop which contains calculations

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

score 1 · Answer 1 · edited May 23 '17 at 12:30

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

edited May 23 '17 at 12:30

Community

1
1

answered May 12 '15 at 12:49

Siddharth Rout

147,039
17
206
250

Compile Error on run: Invalid or unqualified reference: Set delRange = .Rows(i) Should this be Range? Cheers – crash May 12 '15 at 20:10
Even though you have not explained which line is causing the error but I am guessing it is `.Rows(i)` Do you see the DOT before `Rows`? Did you put that code in a Block. If you are running the code for the activesheet then remove the DOTS before `.Rows` everywhere and try again :) – Siddharth Rout May 12 '15 at 20:12
Yup... you were right. (also about hitting enter too early - getting used to this forum). So passed the compiler but Invalid procedure call or argument: Set delRange = Union(delRange, Rows(i)) – crash May 12 '15 at 20:18
Can you update the exact code that you are using in the question above so that I can inspect your code? – Siddharth Rout May 12 '15 at 20:20
You missed the `If delRange Is Nothing Then` line before `Set delRange = .Rows(i)` ;) – Siddharth Rout May 12 '15 at 20:48
Excellent. That worked in about 8 seconds. Thank you. – crash May 12 '15 at 21:01
4 mins to 8 seconds? Awesome ;) – Siddharth Rout May 12 '15 at 21:01

Speeding up For Loop which contains calculations

1 Answers1