Speed Up VBA Code

[jocker_boy]

Hi,

My excel file have 3000 lines and some times cane have 6000 lines or 9000 lines.
I have the code below to fill 3 columns with formula - SUB1()
And to insert subtotal formulas in those 3 columns based on the lenght (columns B).

It's working 100%, but it takes a near 2 minutes each time i run, and i would like to reduce this time.
Is there any way to write this code (SUB2()) to speed up?

I tried to force Calculation Mode to Manual, but the code SUB2 don't run with CalculationManual.

Thanks very much for any help.
Gonçalo

Sub SUB1()
    
    Dim lr As Long
    
'   Find last row in column E with data
    lr = Cells(Rows.Count, "F").End(xlUp).Row
    
'   Copy Range to last column down for all rows
    Range(Cells(6, "A"), Cells(6, "c")).Copy Range(Cells(7, "A"), Cells(lr, "C"))
    
'Apply total formulas
    
    Range(Cells(6, "S"), Cells(lr, "S")).Formula = "=$I6*Q6"
    Range(Cells(6, "U"), Cells(lr, "U")).Formula = "=$I6*J6"
    Range(Cells(6, "AO"), Cells(lr, "AO")).Formula = "=ROUND($I6*AK6,2)"
       
End Sub

Sub SUB2()

Dim r As Long, r2 As Long, last_row As Long
Dim next_row As Long, current_len As Long, test_len As Long
Dim rng As String

Dim i As Integer
Dim cols()
cols = [{"S","U","AO"}]

With ActiveSheet

last_row = .Cells(Rows.Count, 1).End(xlUp).Row

For i = LBound(cols) To UBound(cols)
For r = 6 To last_row
    next_row = r + 1

    If .Range("B" & next_row) > .Range("B" & r) Then
       current_len = .Range("B" & r)
      
       'create range
       For r2 = r + 1 To last_row
            test_len = .Range("B" & r2)
            If current_len >= test_len Then
                rng = cols(i) & r + 1 & ":" & cols(i) & r2 - 1
                Exit For
            End If
        Next
    
        .Range(cols(i) & r).Formula = "=SUBTOTAL(9," & rng & ")"
    End If
    
Next
Next

End With
End Sub

Sub SUBTOTAL()

With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayStatusBar = False
    '.Calculation = xlCalculationManual
End With
 
    Call SUB1
    Call SUB2
 
With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .DisplayStatusBar = True
    '.Calculation = xlCalculationAutomatic
End With

End Sub

 

[jocker_boy]

I did it
i force the manual calculation only in SUB2()

Sub SUBTOTAL()

With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayStatusBar = False
End With
 
    Call SUB1
Application.Calculation = xlCalculationManual
    Call SUB2
Application.Calculation = xlCalculationAutomatic
 
With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .DisplayStatusBar = True
End With

End Sub