Macro to improve Optimisation

[howard]

I have the following code that performs the calculations correctly. Each section starts where "PE" is in row A to first Non-Blank before "Total" for each section

Once the last Text "Total" is found in Col A then macro to end and no more calculations beyond this point. I also have text "Variance" in Col A so calculation not to go beyond this

It is extremely slow as lt appears to be continuing with the loop

It would be appreciated if someone could amend my code. It computes the formulas for each section 100%

 Private Sub ComboBox1_Change()
    Dim peRow As Long, totalRow As Long, endRow As Long
    Dim currentRow As Long, varianceRow As Long
    Dim foundPE As Range, foundTotal As Range, foundVariance As Range
    Dim ws As Worksheet
    Dim sheetName As String

    ' Disable events and screen updating for efficiency
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    ' Set the active worksheet
    Set ws = ActiveSheet
    sheetName = ComboBox1.Value
    
    ' Find the last occurrence of "Variance" in column A to limit the range
    Set foundVariance = ws.Columns("A").Find(What:="Variance", LookAt:=xlWhole)
    If foundVariance Is Nothing Then GoTo Cleanup
    varianceRow = foundVariance.Row
    
    ' Start the search for "PE" from row 1
    currentRow = 1
    
    ' Loop through column A to find sections starting with "PE", but stop at "Variance"
    Do While currentRow < varianceRow
        ' Find the next "PE" in column A
        Set foundPE = ws.Columns("A").Find(What:="PE", After:=ws.Cells(currentRow, "A"), LookAt:=xlWhole)
        
        If foundPE Is Nothing Then Exit Do
        peRow = foundPE.Row
        
        ' Find the next "Total" after "PE"
        Set foundTotal = ws.Columns("A").Find(What:="Total", After:=ws.Cells(peRow, "A"), LookAt:=xlWhole)
        If foundTotal Is Nothing Or foundTotal.Row >= varianceRow Then Exit Do
        totalRow = foundTotal.Row
        
        ' Find the first non-blank row above "Total"
        endRow = totalRow - 1
        Do While ws.Cells(endRow, "A").Value = "" And endRow > peRow
            endRow = endRow - 1
        Loop
        
        ' Set formulas directly for the range
        For i = peRow To endRow
            ws.Cells(i, 2).Formula = "=SUM(Oct:" & sheetName & "!B" & i & ")"
            ws.Cells(i, 3).Formula = "=SUM(Oct:" & sheetName & "!C" & i & ")"
        Next i
        
        ' Move to the next section after "Total"
        currentRow = totalRow + 1
    Loop

Cleanup:
    ' Re-enable events and screen updating
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

 

[Alex Blakenburg]

The logic you need is effectively the same as you use when you use the Range.FindNext method.
A Find which does not involve using Replace eventually loops back on to itself, so you need to capture the first Find and exit the loop when the code loops back to that address.

See if this helps:

Private Sub ComboBox1_Change()

    Dim peRow As Long, totalRow As Long, endRow As Long
    Dim currentRow As Long, varianceRow As Long
    Dim foundPE As Range, foundTotal As Range, foundVariance As Range
    Dim PEAddressFirst As String
    Dim ws As Worksheet
    Dim sheetName As String
    Dim i As Long

    ' Disable events and screen updating for efficiency
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    ' Set the active worksheet
    Set ws = ActiveSheet
    sheetName = ComboBox1.Value
   
    ' Find the last occurrence of "Variance" in column A to limit the range
    Set foundVariance = ws.Columns("A").Find(What:="Variance", LookAt:=xlWhole)
    If foundVariance Is Nothing Then GoTo Cleanup
    varianceRow = foundVariance.Row
   
    ' Start the search for "PE" from row 1
    currentRow = 1
    
    Set foundPE = ws.Columns("A").Find(What:="PE", After:=ws.Cells(currentRow, "A"), LookAt:=xlWhole)
    If Not foundPE Is Nothing Then
        PEAddressFirst = foundPE.Address
        peRow = foundPE.Row
   
        ' Loop through column A to find sections starting with "PE", but stop at "Variance"
        Do           
            ' Find the next "Total" after "PE"
            Set foundTotal = ws.Columns("A").Find(What:="Total", After:=ws.Cells(peRow, "A"), LookAt:=xlWhole)
            If foundTotal Is Nothing Or foundTotal.Row >= varianceRow Then Exit Do
            totalRow = foundTotal.Row
           
            ' Find the first non-blank row above "Total"
            endRow = totalRow - 1
            Do While ws.Cells(endRow, "A").Value = "" And endRow > peRow
                endRow = endRow - 1
            Loop
           
            ' Set formulas directly for the range
            For i = peRow To endRow
                ws.Cells(i, 2).Formula = "=SUM(Oct:" & sheetName & "!B" & i & ")"
                ws.Cells(i, 3).Formula = "=SUM(Oct:" & sheetName & "!C" & i & ")"
            Next i
           
            ' Move to the next section after "Total"
            currentRow = totalRow + 1
           
            ' Find the next "PE" in column A
            Set foundPE = ws.Columns("A").Find(What:="PE", After:=ws.Cells(currentRow, "A"), LookAt:=xlWhole)
            peRow = foundPE.Row
        Loop While currentRow < varianceRow And foundPE.Address <> PEAddressFirst
   
    End If

Cleanup:
    ' Re-enable events and screen updating
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

 

[howard]

Many thanks for your explanation and revised code Alex

It works 100% and super fast

 

[Alex Blakenburg]

Appreciate the feedback. Glad I could help.