Solved: Subtotal() generates extra lines

[Paul_Hossler]

I know I could use a pivot table, but this time I need to use the SUBTOTAL () function to embed the formulas into the worksheet

Overview is I have 3 control break fields and 4 data fields, and at each change in the value of each of the control fields, I want to get a SUBTOTAL(9, ...) formula.

The Excel (2007 BTW) [Data][Subtotal] works mostly OK, as does the VBA.

However ....

SummaryBelowData:=True generates extraneous (or at least I don't want them) Grand Total lines for the 2nd and 3rd level control breaks

SummaryBelowData:=False does not generate extraneous Grand Total lines for the 2nd and 3rd level control breaks, but I'd rather that the Grand Total at the botton. It also seems to generate the total lines out of order, 2nd, 1st, 3rd, instead of highest (1st) to lowest (3rd)

1. Am I doing something wrong (always a possibility), or
2. Is there a workaround


[VBA]
Option Explicit

Sub SubtotalQuestion()
Dim rHeadersData As Range, rData As Range
Set rHeadersData = ActiveSheet.Cells(1, 1).CurrentRegion
With rHeadersData
Set rData = .Cells(2, 1).Resize(.Rows.Count - 1, .Columns.Count)
.RemoveSubtotal
End With

With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=rData.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rData.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rData.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rHeadersData
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With


With rHeadersData
'case 1 -- Summary Below
' .Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(4, 5, 6, 7), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
' .Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(4, 5, 6, 7), Replace:=False, PageBreaks:=False, SummaryBelowData:=True
' .Subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(4, 5, 6, 7), Replace:=False, PageBreaks:=False, SummaryBelowData:=True

'case 2 -- Summary above
.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(4, 5, 6, 7), Replace:=True, PageBreaks:=False, SummaryBelowData:=False
.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(4, 5, 6, 7), Replace:=False, PageBreaks:=False, SummaryBelowData:=False
.Subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(4, 5, 6, 7), Replace:=False, PageBreaks:=False, SummaryBelowData:=False

End With

End Sub
[/VBA]

Paul

[Paul_Hossler]

I think I was doing it to myself by not realizing that I was applying the 2nd and 3rd Subtotals to the original range, and forgetting that the range was expanded by the 1st Subtotal

[VBA]
Option Explicit

Sub SubtotalQuestion_1()
Dim rHeadersData As Range, rData As Range
Set rHeadersData = ActiveSheet.Cells(1, 1).CurrentRegion
With rHeadersData
Set rData = .Cells(2, 1).Resize(.Rows.Count - 1, .Columns.Count)
.RemoveSubtotal
End With

With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=rData.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rData.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rData.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rHeadersData
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With


Set rHeadersData = ActiveSheet.Cells(1, 1).CurrentRegion
rHeadersData.RemoveSubtotal
rHeadersData.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(4, 5, 6, 7), Replace:=False, PageBreaks:=False, SummaryBelowData:=True

Set rHeadersData = ActiveSheet.Cells(1, 1).CurrentRegion
rHeadersData.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(4, 5, 6, 7), Replace:=False, PageBreaks:=False, SummaryBelowData:=True

Set rHeadersData = ActiveSheet.Cells(1, 1).CurrentRegion
rHeadersData.Subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(4, 5, 6, 7), Replace:=False, PageBreaks:=False, SummaryBelowData:=True

End Sub
[/VBA]



Paul