Subtotal by Category: Insert Group Totals and a Grand Total With Two Clicks

TL;DR: Select the category column with your mouse, select the value column with your mouse — that’s it. The macro sorts your data if needed, inserts SUBTOTAL rows at every group change, adds a grand total with double underline, and creates collapsible outline groups. Two clicks, one MsgBox summary. The Data → Subtotal dialog just became a single hotkey.

#Prerequisites & Setup

What you’ll need:

• Excel 2016+ (desktop)
• A sheet with data you want grouped — a fixed asset schedule, a trial balance, a depreciation listing, any categorized list
• Column headers in row 1
• The category column should have repeating values (e.g., multiple rows per asset class)

Limitations:

• Works on the active sheet only — run once per sheet
• Requires data to be sorted by the category column (the macro offers to sort for you)
• Removes any existing subtotals before applying new ones — the macro warns and is non-destructive to data, but the old grouping structure is replaced
• Only subtotals one value column at a time — if you need subtotals on multiple columns, run the macro once per column or use the built-in Data → Subtotal dialog

#The Macro

Option Explicit

Sub SubtotalByCategory()
    ' ── Subtotal by Category ──────────────────────────
    ' Groups rows by a category column, inserts SUBTOTAL
    ' formulas at each group change, and adds a grand
    ' total. Creates collapsible outline groups.
    '
    ' Two mouse-click selections — no typing, no menus.
    ' ────────────────────────────────────────────────────

    ' ── State management ───────────────────────────────
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    ' ── Error handling ─────────────────────────────────
    On Error GoTo CleanUp

    Dim catRng As Range, valRng As Range, ws As Worksheet
    Dim catCol As Long, valCol As Long, lastCol As Long
    Dim lastRow As Long, i As Long, catCount As Long

    ' ── User selects columns with mouse ────────────────
    On Error Resume Next
    Set catRng = Application.InputBox( _
        "Click any cell in the CATEGORY column", _
        "Category Column", Type:=8)
    If catRng Is Nothing Then GoTo CleanUp
    Set valRng = Application.InputBox( _
        "Click any cell in the VALUE column", _
        "Value Column", Type:=8)
    If valRng Is Nothing Then GoTo CleanUp
    On Error GoTo CleanUp

    Set ws = ActiveSheet
    catCol = catRng.Column
    valCol = valRng.Column
    lastRow = ws.Cells(ws.Rows.Count, catCol).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

    If lastRow <= 1 Then
        MsgBox "No data found in the category column.", vbExclamation
        GoTo CleanUp
    End If

    ' ── Sort by category if needed ─────────────────────
    For i = 2 To lastRow - 1
        If CStr(ws.Cells(i, catCol)) > _
           CStr(ws.Cells(i + 1, catCol)) Then
            If MsgBox("Data must be sorted by category. Sort now?", _
                      vbYesNo + vbQuestion, "Sort Required") = vbNo Then
                MsgBox "Subtotals need sorted data. Please sort first.", _
                       vbExclamation
                GoTo CleanUp
            End If
            With ws.Sort
                .SortFields.Clear
                .SortFields.Add Key:=ws.Columns(catCol), _
                    SortOn:=xlSortOnValues, Order:=xlAscending
                .SetRange ws.Range(ws.Cells(1, 1), _
                    ws.Cells(lastRow, lastCol))
                .Header = xlYes
                .Apply
            End With
            Exit For
        End If
    Next i

    ' ── Count categories before applying ───────────────
    On Error Resume Next
    ws.Cells.RemoveSubtotal
    On Error GoTo CleanUp

    catCount = 1
    For i = 3 To lastRow
        If CStr(ws.Cells(i, catCol).Value) <> _
           CStr(ws.Cells(i - 1, catCol).Value) Then
            catCount = catCount + 1
        End If
    Next i

    ' ── Apply SUBTOTAL outlines ────────────────────────
    ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol)).Subtotal _
        GroupBy:=catCol, Function:=xlSum, _
        TotalList:=Array(valCol), Replace:=True, _
        PageBreaks:=False, SummaryBelowData:=True

    ' ── Format subtotal and grand total rows ───────────
    Dim r As Long, grandRow As Long
    grandRow = ws.Cells(ws.Rows.Count, catCol).End(xlUp).Row

    For r = 2 To grandRow
        If InStr(1, CStr(ws.Cells(r, catCol).Value), _
                 "Total", vbTextCompare) > 0 Then
            ws.Rows(r).Font.Bold = True
            ws.Cells(r, valCol).NumberFormat = "#,##0.00"
            With ws.Range(ws.Cells(r, 1), ws.Cells(r, lastCol))
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
                .Borders(xlEdgeBottom).Weight = xlThin
            End With
            If InStr(1, CStr(ws.Cells(r, catCol)), _
                     "Grand", vbTextCompare) > 0 Then
                With ws.Range(ws.Cells(r, 1), ws.Cells(r, lastCol))
                    .Borders(xlEdgeBottom).LineStyle = xlDouble
                    .Borders(xlEdgeBottom).Weight = xlThick
                End With
            End If
        End If
    Next r

    ' ── Report ─────────────────────────────────────────
    MsgBox "Inserted " & catCount & " subtotal(s) for " & _
           catCount & " categor" & IIf(catCount = 1, "y", "ies") & _
           "." & vbCrLf & vbCrLf & _
           "Grand total: " & Format(ws.Cells(grandRow, valCol), _
           "$#,##0.00") & vbCrLf & vbCrLf & _
           "Use the outline controls (+/−) on the left " & _
           "to collapse or expand groups.", _
           vbInformation, "Subtotals Complete"

CleanUp:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    If Err.Number <> 0 Then
        MsgBox "Error " & Err.Number & ": " & Err.Description, _
               vbCritical, "Macro Error"
    End If
End Sub

#How It Works

#Application.InputBox(Type:=8) — the user clicks, not types

The macro uses two Application.InputBox(Type:=8) prompts. The Type:=8 argument tells Excel to accept a range reference — the user clicks any cell in the target column and hits OK. No typing column letters, no guessing which column is “C” vs “D”. Someone who has never opened the VBA editor can run this macro. The If catRng Is Nothing Then GoTo CleanUp handles the Cancel button — if the user hits Cancel or closes the dialog, the macro exits cleanly without error.

Set catRng = Application.InputBox( _
    "Click any cell in the CATEGORY column", _
    "Category Column", Type:=8)

The .Column property of the returned range gives you the column number. You don’t need to know the letter — the macro figures it out from wherever the user clicked.

#Sort check — one pass through the data, one pass only

Most subtotal implementations just silently sort the data without asking. This one checks first: it walks down the category column and compares each row to the one below. If it finds any pair where A > B, the data isn’t sorted. It then asks — “Sort now?” — rather than assuming. If the user says no, the macro stops with a clear message instead of producing garbage.

For i = 2 To lastRow - 1
    If CStr(ws.Cells(i, catCol)) > _
       CStr(ws.Cells(i + 1, catCol)) Then
        ' Data is unsorted — prompt

The CStr() conversion is critical: if the category column contains a mix of numbers and text (account codes stored as numbers in some rows and text in others), VBA’s default comparison can produce wrong results. Casting both sides to CStr forces a consistent text comparison.

If the user accepts sorting, the macro sorts the entire data range — not just the category column — using the header row as the sort anchor:

.SetRange ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol))
.Header = xlYes

This is the same sort pattern the user would get from Data → Sort → Expand the selection — all columns stay aligned with their rows.

#RemoveSubtotal — always clean up before applying

On Error Resume Next
ws.Cells.RemoveSubtotal
On Error GoTo CleanUp

If you ran the macro on this sheet before, the old subtotals are still there. Applying new subtotals on top of old ones creates nested group levels that make the outline buttons unreadable. RemoveSubtotal strips all existing outline groups first. The On Error Resume Next handles the case where there are no subtotals to remove (the method throws an error on a sheet with no outline).

#The Subtotal method — Excel’s native grouping API

ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol)).Subtotal _
    GroupBy:=catCol, Function:=xlSum, _
    TotalList:=Array(valCol), Replace:=True, _
    PageBreaks:=False, SummaryBelowData:=True

This is the same API the Data → Subtotal dialog calls internally. Every argument maps to a choice in that dialog:

• GroupBy:=catCol — “At each change in:”
• Function:=xlSum — “Use function: Sum”
• TotalList:=Array(valCol) — “Add subtotal to:” (the value column)
• SummaryBelowData:=True — puts subtotals below each group, which is the standard layout for tax workpapers

The result is identical to the dialog — properly structured outline groups with SUBTOTAL formulas. But because the macro handles all the setup (column selection, sorting, and cleanup) in one flow, it’s faster than navigating the dialog and less error-prone than picking the wrong options.

#Finding subtotal rows — the “Total” label is the key

After Subtotal runs, Excel appends ” Total” (space + Total) to every category value in the subtotal rows — e.g., “Equipment Total”, “Land Total”. The macro uses InStr with vbTextCompare to find these rows and apply formatting:

If InStr(1, CStr(ws.Cells(r, catCol).Value), _
         "Total", vbTextCompare) > 0 Then

The grand total row contains “Grand Total”, which also passes this check. The macro gives grand total a double underline (accounting convention: single underline for subtotals, double underline for the final number). It uses a nested InStr to distinguish:

If InStr(1, CStr(ws.Cells(r, catCol)), _
         "Grand", vbTextCompare) > 0 Then
    ' Double underline for grand total

#Why the category count comes before the subtotal call

The macro counts unique categories before inserting subtotals. If it waited until after, it would have to filter out the subtotal rows from the count (each one appends ” Total” to the category name, which would look like a new category). Counting before is cleaner:

catCount = 1
For i = 3 To lastRow
    If CStr(ws.Cells(i, catCol).Value) <> _
       CStr(ws.Cells(i - 1, catCol).Value) Then
        catCount = catCount + 1
    End If
Next i

#IIf for clean grammar in the message box

catCount & " categor" & IIf(catCount = 1, "y", "ies")

If there’s one category, the message reads “1 category”. If there are four, it reads “4 categories”. A small detail, but the message box at the end is the only output the user sees — it should read like a person wrote it.

#State management — the standard safety net

Like every macro on this blog, ScreenUpdating and Calculation are toggled at the top and restored in CleanUp at the bottom. Even if the user cancels mid-way (clicks Cancel on an InputBox), the GoTo CleanUp path runs the restore code. A macro that leaves Calculation in manual mode is a support ticket waiting to happen.

#Adapt It