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

'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) <> ""
If Range("B" & i) <> Range("B" & (i + 1)) Then
Rows(i + 1).Insert
Range("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 iCol
Range(Cells(i + 1, 1), Cells(i + 1, 8)).Font.Bold=True
i=i + 2
i=i + 1
End If
Application.ScreenUpdating= True
End Sub

The following will remove the subtotals you just added.

Sub Restore()
End Sub

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