## Excel VBA to Create Subtotals on the Fly

## In Excel you can make a subtotal with the help of VBA, so the totals are generated automatically. I have found occasions where I have wanted to perform a subtotal but I did not want to use Excel’s inbuilt Subtotal feature as the data was a different size and shape each time. I wanted to have a bit more control over the look and feel of the end product than Excel's inbuilt Subtotal function. So I created a procedure which will produce a Sum on the fly, where like items are grouped together and a subtotal for each group of items is produced. Here is a screen shot of the procedure before it is run.

The following is what the file looks like after the procedure has run.

This can be done with the following code;

Option Explicit

Sub aSubTotal() 'Excel VBA to create subtotals.

Dim iCol As Integer

Dim i As Integer

Dim j As Integer

Application.ScreenUpdating=False

i=11

j=i

'Sort the data so like data is grouped together.

Range("B11").CurrentRegion.Offset(1).Sort Range("B12"), 1

End Sub

The following will remove the subtotals you just added.

Sub Restore()

The Excel file contains the VBA procedure and the example dataset shown above.

Sub aSubTotal() 'Excel VBA to create subtotals.

Dim iCol As Integer

Dim i As Integer

Dim j As Integer

Application.ScreenUpdating=False

i=11

j=i

'Sort the data so like data is grouped together.

Range("B11").CurrentRegion.Offset(1).Sort Range("B12"), 1

'Loops throught Col B Checking for match then when there is no match add Sum

Do While Range("B" & i) <> ""

Application.ScreenUpdating= TrueDo While Range("B" & i) <> ""

If Range("B" & i) <> Range("B" & (i + 1)) Then

LoopRows(i + 1).Insert

Range("B" & (i + 1))="Subtotal " & Range("B" & i).Value

For iCol=5 To 8 'Columns to Sum

Range(Cells(i + 1, 1), Cells(i + 1, 8)).Font.Bold=True

i=i + 2

j=i

ElseRange("B" & (i + 1))="Subtotal " & Range("B" & i).Value

For iCol=5 To 8 'Columns to Sum

Cells(i + 1, iCol).Formula="=SUM(R" & j & "C:R" & i & "C)"

Next iColRange(Cells(i + 1, 1), Cells(i + 1, 8)).Font.Bold=True

i=i + 2

j=i

i=i + 1

End IfEnd Sub

The following will remove the subtotals you just added.

Sub Restore()

[a11:A100].SpecialCells(4).EntireRow.Delete

End SubThe Excel file contains the VBA procedure and the example dataset shown above.