Subtotal Formatting

[Haas C]

Hi all,

When creating subtotals, Excel doesn't put in blank rows after each grouping. I have created a macro which would essentially take data that I collect on a monthly basis and create subtotals on certain columns and group them by a change in the Company name. What I need to include in that is the ability to separate the subtotal groups by a blank row. This is what I have thusfar what would I need to add at the end of the code to insert a blank row before displaying the next subtotal group?:

Range("A3").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Columns.AutoFit
Application.CutCopyMode = False
Selection.Subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(10, 11, 12 _
, 13, 14, 15, 16, 17, 18, 19, 20), Replace:=True, PageBreaks:=False, SummaryBelowData:= _
True
Range("A3").Select

Thanks for any and all help

 

[Ben McClave]

Hello Haas,

Try the code below. It seemed to work for me.

Hope this helps,

Ben

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

Set rValues = Range("A3").CurrentRegion
With rValues
.Columns.AutoFit
Application.CutCopyMode = False
lRow(1) = .Rows.Count
.Subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(10, 11, 12 _
, 13, 14, 15, 16, 17, 18, 19, 20), Replace:=True, PageBreaks:=False, SummaryBelowData:= _
True
lRow(2) = .CurrentRegion.Rows.Count
If lRow(2) = lRow(1) Then Exit Sub 'user cancelled sub-total, so exit
Set rValues = .Resize(lRow(2), 3)
End With

For Each c In rValues
If Right(c.Value, 5) = "Total" Then
strArray = strArray & ", " & c.Address
End If
Next c

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


Set rValues = Nothing

End Sub

 

[Haas C]

Hello Haas,



Try the code below. It seemed to work for me.



Hope this helps,



Ben



Sub AddSubTotalRow()

Dim rValues As Range

Dim c As Range

Dim lRow(1 To 2) As Long

Dim strArray As String



Set rValues = Range("A3").CurrentRegion

With rValues

.Columns.AutoFit

Application.CutCopyMode = False

lRow(1) = .Rows.Count

.Subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(10, 11, 12 _

, 13, 14, 15, 16, 17, 18, 19, 20), Replace:=True, PageBreaks:=False, SummaryBelowData:= _

True

lRow(2) = .CurrentRegion.Rows.Count

If lRow(2) = lRow(1) Then Exit Sub 'user cancelled sub-total, so exit

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

End With



For Each c In rValues

If Right(c.Value, 5) = "Total" Then

strArray = strArray & ", " & c.Address

End If

Next c



strArray = Right(strArray, Len(strArray) - 2)

Set rValues = Range(strArray).Offset(1, 0)

rValues.EntireRow.Insert





Set rValues = Nothing



End Sub

Excellent - thanks much!