Good Evening,

This might not be the most elegant way to accomplish what you're looking for, but the macro below works with your sample data. There are a few comments in the code to help you customize it. Essentially, the macro uses the Subtotal function to create subtotals, then goes through the newly-subtotaled data to change the way the total is displayed and insert a blank line. Optionally, you can remove the Grand Total and/or grouping.

Hope this helps.

Ben

Sub AddSubTotal()
Dim rValues As Range
Dim c As Range
Dim lRow(1 To 2) As Long
Dim strArray As String
Dim l As Long

'Delete next few lines of code if you wish to specify the range in code rather than by _
prompting the user.
On Error Resume Next
Set rValues = Application.InputBox("Please select a range", "Data Range", , , , , , 8)
On Error GoTo 0
If rValues Is Nothing Then
MsgBox ("Invalid Range")
Exit Sub
End If

'If not using inputbox method above, uncomment the next line
'Set rValues = Range("A1:B10")

lRow(1) = rValues.Rows.Count
rValues.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(2), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
lRow(2) = rValues.CurrentRegion.Rows.Count
If lRow(2) = lRow(1) Then Exit Sub 'user cancelled sub-total, so exit

Set rValues = rValues.Resize(lRow(2), 1)

For Each c In rValues
If c.Value = "Grand Total" Then
'Uncomment next 2 lines to clear Grand Total line
'c.ClearContents
'c.Offset(0, 1).ClearContents
ElseIf Right(c.Value, 5) = "Total" Then
l = l + 1
strArray = strArray & ", " & c.Address
c.Value = "<b" & c.Offset(0, 1).Value & "</b"
c.Offset(0, 1).Value = vbNullString
End If
Next c

strArray = Right(strArray, Len(strArray) - 2)
Set rValues = Range(strArray).Offset(1, 0)
rValues.EntireRow.Insert

'Uncomment next line if not using Grand Total
'Range("1:" & lRow(2) + l).Rows.Ungroup

'Uncomment next line to ungroup remaining rows
'Range("1:" & lRow(2) + l).Rows.Ungroup

Set rValues = Nothing

End Sub