Hi Reader,

This post will show you how to add subtotals on a variable group by column and total column, and it will also show you how to add some color to the subtotal rows to make them stand out.

Here is what the data to which we want to add the subtotals looks like:

and here is what it will look like after the code is run…

Here is the code:

Sub PlaceSubtotals()

    Dim strCurrentSheet As String
    Dim intLastRow As Integer
    Dim intGroupByCol As Integer
    Dim intTotalCol As Integer
    
    Dim intRow As Integer
    
    strCurrentSheet = ActiveSheet.Name
    intLastRow = FindLastRow("A")
    
    '***************************************************************
    'which column do we want to group by and enter the subtotals?
    '***************************************************************
    intGroupByCol = 3
    intTotalCol = 4
       
    '*********************************************
    'sort the group by column
    '*********************************************
    Range(ActiveSheet.Cells(1, intGroupByCol).Address).Select
    ActiveWorkbook.Worksheets(strCurrentSheet).Sort.SortFields.Clear
    
    ActiveWorkbook.Worksheets(strCurrentSheet).Sort.SortFields.Add2 Key:=Range( _
        Cells(2, intGroupByCol).Address), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
            
    '*********************************************
    'implement the subtotals
    '*********************************************
    With ActiveWorkbook.Worksheets(strCurrentSheet).Sort
        .SetRange Range("A2:F" & intLastRow)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    '*********************************************
    'at each change in the GroupBy field add a total in the TotalList field
    '*********************************************
    Selection.Subtotal GroupBy:=intGroupByCol, Function:=xlSum, TotalList:=intTotalCol, _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
        
    '*********************************************
    'finally add color to the subtotal cells
    '*********************************************
    intLastRow = FindLastRow2(intGroupByCol)
    For intRow = 2 To intLastRow
        If InStr(1, Cells(intRow, intGroupByCol), "Total") Then

            Range(ActiveSheet.Cells(intRow, intGroupByCol).Address).Select
            With Selection.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 65535
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
            
        End If
    Next
    
End Sub

Function FindLastRow(WhichColumn As String) As Long
    
    'FINDS THE LAST ROW BASED ON THE COLUMN LETTER <---
    
    Dim lngLastRow As Long
    
    'move to the last row on the worksheet and find the last used cell.
    
    With ActiveSheet
        lngLastRow = ActiveSheet.Cells(1048576, WhichColumn).End(xlUp).Row
    End With

    FindLastRow = lngLastRow

End Function

Function FindLastRow2(WhichColumn As Integer) As Long

    'FINDS THE LAST ROW BASED ON THE COLUMN NUMBER <---
    
    Dim lngLastRow As Long
    
    'move to the last row on the worksheet and find the last used cell.
    
    With ActiveSheet
        lngLastRow = ActiveSheet.Cells(1048576, WhichColumn).End(xlUp).Row
    End With

    FindLastRow2 = lngLastRow

End Function

Let me know if you have any questions.