VBA Subtotal 47,000+ Rows

[mattyj7183]

Hello -

I have a sheet full of billing groups and their accounts, with account values and billable amount. In some cases, there is only one account in a billing group, but most of the time, there are multiple accounts within the same group. I'm using VBA to calculate a subtotal of both the value and billable amount for each group, and then copy down formulas to feed into a separate sheet. The code takes hours, sometimes crashing, since it is 47,000+ rows long. I tried breaking it into chunks, 1000 rows at a time, but it has yet to run successfully. It's worth noting that this worked when the data set was 1500 rows long (without chunking), but it struggles with 47,000 rows, and hoped there was a better way.

Any suggestions/updates to the code are welcome.

Sub Format_Fees()
    Dim lastRow As Long
    Dim ws As Worksheet
    Dim chunkSize As Long
    Dim currentRow As Long
    Dim endRow As Long
    Dim groupValue As Variant

    ' Turn off screen updating, events, and automatic calculation
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    On Error GoTo ErrorHandler

    ' Set worksheet and find last row based on column A
    Set ws = ThisWorkbook.Sheets("Data Drop - From Custom View")
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    ' Ensure there's data to process
    If lastRow < 2 Then GoTo CleanUp

    ' Define chunk size (e.g., 500 rows)
    chunkSize = 500
    currentRow = 2 ' Start processing from row 2 to skip the headers

    ' Loop through the data in chunks
    Do While currentRow <= lastRow
        endRow = currentRow + chunkSize - 1
        If endRow > lastRow Then endRow = lastRow

        ' Ensure that chunk doesn't split groups
        If endRow < lastRow Then
            groupValue = ws.Cells(endRow, 2).Value ' Assuming grouping is based on column B
            Do While ws.Cells(endRow + 1, 2).Value = groupValue And endRow < lastRow
                endRow = endRow + 1
            Loop
        End If

        ' Update formulas in column F for the current chunk
        With ws.Range("F" & currentRow & ":F" & endRow)
            .FormulaR1C1 = "=IFNA(XLOOKUP(RC1, 'Data Drop - From Custom View'!C1, 'Fees Export - From Billing'!C2, 0), 0)"
        End With

        ' Apply subtotals to the current chunk, including the header row in the selection
        With ws.Range("A1:I" & endRow) ' Ensure headers are included by starting from A1
            .Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(5, 6), _
                Replace:=False, PageBreaks:=False, SummaryBelowData:=True
        End With

        currentRow = endRow + 1
    Loop

    ' Update formulas in column H for all rows
    With ws.Range("H2:H" & lastRow)
        .FormulaR1C1 = "=IFERROR(IF(RC[-2]="""","""", (RC[-2]*6)/RC[-3]), 0)"
    End With

    GoTo CleanUp

ErrorHandler:
    MsgBox "An error occurred: " & Err.Description & " (Line: " & Erl & ")", vbCritical

CleanUp:
    ' Restore application settings
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

 

[igold]

Are you dead set on using Subtotals or are using them because it is getting you close to your requirement. It would be nice to see a small set of data (real or ficticious) with a sample of how the data looks before and how you would like it to look after the code is run.