Hello all,

I have a spreadsheet that I am trying to automatically subtotal and add a break before moving to the next group.

Example of how it is now:

test 1 10
test 1 10
test 1 10
test 2 20
test 2 20
test 2 20
test 3 30
test 3 30
test 3 30

Right now I can use the subtotal tool which will do this:

test 1 10
test 1 10
test 1 10
test 1 total 30
test 2 20
test 2 20
test 2 20
test 2 total 80
test 3 30
test 3 30
test 3 30
test 3 total 90

I need to know how to do a macro or format excel to make it look like this:

test 1 10
test 1 10
test 1 10
<b30</b

test 2 20
test 2 20
test 2 20
<b80</b

test 3 30
test 3 30
test 3 30
<b90</b


Please help me! thank you

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