Speed Up Code

[THRASHER69]

Hello,

I'm hoping someone here can tell me if there is a way to write the below code that would make it run faster. It is really slowing down things. I know it is doing a lot but it's taking 10 around 10 minutes just for this part of the code. Any help would be much appreciated. I highlighted the section of code I am having issues with in red:

lr = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1        
        TRow = "Conf. Date"
        Cells.Find(what:=TRow).Activate
        TRow = ActiveCell.Row
        For i = lr To TRow Step -1
            AItem = Cells(i - 1, 1).Address
            EItem = Cells(i - 1, 5).Address
            RCnt = Application.Evaluate("SumProduct(--(A:A=" & AItem & "),--(E:E=" & EItem & "))")
            If i - RCnt < TRow Then GoTo 0
            If i = lr Then
                x = Cells(i - RCnt, "I").Address
                y = Cells(i - 1, "I").Address
                Cells(i, "I").Formula = "=SUBTOTAL(9," & x & ":" & y & ")"
                Cells(i - 1, "I").Copy
                Cells(lr, "I").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                                            SkipBlanks:=False, Transpose:=False
            End If
[COLOR=#ff0000]            If Cells(i, "E") <> Cells(i - 1, "E") And i <> lr Then[/COLOR]
[COLOR=#ff0000]                Rows(i).Resize(2).EntireRow.Insert[/COLOR]
[COLOR=#ff0000]                Range(Cells(TRow, "A"), Cells(TRow, "J")).Copy Destination:=Range("A" & i + 1)[/COLOR]
[COLOR=#ff0000]                x = Cells(i - RCnt, "I").Address[/COLOR]
[COLOR=#ff0000]                y = Cells(i - 1, "I").Address[/COLOR]
[COLOR=#ff0000]                Cells(i, "I").Formula = "=SUBTOTAL(9," & x & ":" & y & ")"[/COLOR]
[COLOR=#ff0000]                Cells(i, "I").Font.Bold = True[/COLOR]
[COLOR=#ff0000]                Cells(i, "I").Font.Size = 12[/COLOR]
[COLOR=#ff0000]                Cells(i, "I").Font.Color = RGB(255, 0, 0)[/COLOR]
[COLOR=#ff0000]            End If[/COLOR]
        Next i

 

[AKR22]

This is usually my go to for just about any large processes. Your main concern should be with the "application.calculation" because Excel is trying to calculate once a row has been changed each and every time.

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

' insert code here

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

 

[THRASHER69]

I actually have exactly that at the beginning and end of my code. Unfortunately, the part in red is still extremely slow

 

[mrhstn]

The only thing which differs between the two if statements is application of font styling, I doubt this is the cause of your processing speed issue.

You've told us that more of the code exists... perhaps if the whole thing was available someone might be able to pinpoint the problem a little better.

 

[THRASHER69]

The whole thing is very very long. Is there any kind of rule on how long the code can be?

 

[mrhstn]

Not really, but I've had another look at this. It could be that part of the procedure takes 10 minutes because it's going to act on every row, it may just be that there's a lot of rows. Is there maybe a better way of doing what you need to do without inserting a row at every iteration of the for next loop?

Anyhoo... Have a bash with this, see if it a) does the same thing, b) runs any quicker.

Sub THRASHER()
Dim lr As Long, i As Long
Dim x As String, y As String
Dim Found As Range
Dim TRow As Long
Dim AItem, EItem, RCnt
0
lr = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
        Set Found = Cells.Find(what:="Conf. Date")
        If Not Found Is Nothing Then
            TRow = Found.Row
            For i = lr To TRow Step -1
                AItem = Cells(i - 1, 1).Address
                EItem = Cells(i - 1, 5).Address
                RCnt = Application.Evaluate("SumProduct(--(A1:A" & lr & "=" & AItem & "),--(E1:E" & lr & "=" & EItem & "))")
                x = Cells(i - RCnt, "I").Address
                y = Cells(i - 1, "I").Address
                
                If i - RCnt < TRow Then GoTo 0
                If Cells(i, "E") <> Cells(i - 1, "E") And i <> lr Then
                    Rows(i).Resize(2).EntireRow.Insert
                    Range(Cells(TRow, "A"), Cells(TRow, "J")).Copy Destination:=Range("A" & i + 1)
                    With Cells(i, "I")
                        .Formula = "=SUBTOTAL(9," & x & ":" & y & ")"
                        .Font.Bold = True
                        .Font.Size = 12
                        .Font.Color = RGB(255, 0, 0)
                    End With
                ElseIf i = lr Then
                    Cells(i, "I").Formula = "=SUBTOTAL(9," & x & ":" & y & ")"
                    Cells(lr, "I").Format = Cells(i - 1, "I").Format
                End If
            Next i
        End If
End Sub

 

[THRASHER69]

I get a run time error 438, object doesn't support this property or method on the line in red below

Not really, but I've had another look at this. It could be that part of the procedure takes 10 minutes because it's going to act on every row, it may just be that there's a lot of rows. Is there maybe a better way of doing what you need to do without inserting a row at every iteration of the for next loop?

Anyhoo... Have a bash with this, see if it a) does the same thing, b) runs any quicker.

Sub THRASHER()
Dim lr As Long, i As Long
Dim x As String, y As String
Dim Found As Range
Dim TRow As Long
Dim AItem, EItem, RCnt
0
lr = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
        Set Found = Cells.Find(what:="Conf. Date")
        If Not Found Is Nothing Then
            TRow = Found.Row
            For i = lr To TRow Step -1
                AItem = Cells(i - 1, 1).Address
                EItem = Cells(i - 1, 5).Address
                RCnt = Application.Evaluate("SumProduct(--(A1:A" & lr & "=" & AItem & "),--(E1:E" & lr & "=" & EItem & "))")
                x = Cells(i - RCnt, "I").Address
                y = Cells(i - 1, "I").Address
                
                If i - RCnt < TRow Then GoTo 0
                If Cells(i, "E") <> Cells(i - 1, "E") And i <> lr Then
                    Rows(i).Resize(2).EntireRow.Insert
                    Range(Cells(TRow, "A"), Cells(TRow, "J")).Copy Destination:=Range("A" & i + 1)
                    With Cells(i, "I")
                        .Formula = "=SUBTOTAL(9," & x & ":" & y & ")"
                        .Font.Bold = True
                        .Font.Size = 12
                        .Font.Color = RGB(255, 0, 0)
                    End With
                ElseIf i = lr Then
                    Cells(i, "I").Formula = "=SUBTOTAL(9," & x & ":" & y & ")"
                    Cells(lr, "I").Format = Cells(i - 1, "I").Format
                End If
            Next i
        End If
End Sub

 

[mrhstn]

I see, switch it out for the original...

Cells(i - 1, "I").Copy
Cells(lr, "I").PasteSpecial xlPasteFormats