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.