Insert Sub Total at page break

[BexleyManor]

I have a huge list in a worksheet that I would really like to have a sub total inserted at every page break and the total is to be for each page, not a running total.

I seem unable to use the subtotal function because each item on the list is unique so wondered if any of you kind folks could suggest some code as my head hurts from thinking!! :doh:

[austenr]

Sub InsertSubtotals(SourceRange As Range)
' inserts subtotals at the bottom of each page in the active worksheet
' creates a new workbook/worksheet containing the values from the SourceRange in
' the active sheet since the process is not reversible without further programming
Dim TargetWB As Workbook, AWB As String
Dim TotalPageBreaks As Long, pbIndex As Long, pbRow As Long, PreviousPageBreak As Long
Application.ScreenUpdating = False
' create a new workbook/worksheet containing the values from the active sheet
Application.StatusBar = "Creating report workbook..."
AWB = ActiveWorkbook.Name
Set TargetWB = Workbooks.Add
Application.DisplayAlerts = False
While TargetWB.Worksheets.Count > 1
TargetWB.Worksheets(2).Delete
Wend
Application.DisplayAlerts = True
Workbooks(AWB).Activate
SourceRange.Copy
TargetWB.Activate
With Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
' copy the column widths and row heights if necessary
CopyColumnWidths TargetWB.Worksheets(1).Cells, SourceRange
CopyRowHeights TargetWB.Worksheets(1).Cells, SourceRange
' insert subtotals
pbIndex = 0
PreviousPageBreak = 1
TotalPageBreaks = ActiveSheet.HPageBreaks.Count
While pbIndex < TotalPageBreaks
pbIndex = pbIndex + 1
Application.StatusBar = "Inserting subtotal " & pbIndex & " of " & TotalPageBreaks + 1 _
& " (" & Format(pbIndex / (TotalPageBreaks + 1), "0%") & ")..."
pbRow = GetHPageBreakRow(pbIndex)
If pbRow > 0 Then
InsertSubTotal pbRow, PreviousPageBreak, True, "Page Subtotal:"
PreviousPageBreak = pbRow
TotalPageBreaks = ActiveSheet.HPageBreaks.Count
Else
pbRow = TotalPageBreaks
End If
Wend
' add the last subtotal
Application.StatusBar = "Inserting the last subtotal..."
InsertSubTotal Range("A65536").End(xlUp).Row + 1, PreviousPageBreak, False, "Page Subtotal:"
' add the grand total
Application.StatusBar = "Inserting the grand total..."
InsertSubTotal Range("A65536").End(xlUp).Row + 1, 1, False, "Grand Total:"
Range("A1").Select
Application.StatusBar = False
End Sub
Private Sub InsertSubTotal(RowIndex As Long, _
PreviousPageBreak As Long, InsertNewRows As Boolean, LabelText As String)
' contains all editing necessary for each subtotal at the bottom of each page
' customization is necessary depending on the subtotals you want to add
Const RowsToInsert As Long = 3
Dim i As Long, TargetRow As Long
TargetRow = RowIndex
If InsertNewRows Then ' not the last subtotal
For i = 1 To RowsToInsert
Rows(RowIndex - RowsToInsert).Insert
Next i
TargetRow = RowIndex - RowsToInsert
End If
If PreviousPageBreak < 1 Then PreviousPageBreak = 1
' insert the necessary subtotal formulas here:
Cells(TargetRow, 1).Formula = LabelText
With Cells(TargetRow, 3)
.Formula = "=subtotal(9,r[-" & TargetRow - PreviousPageBreak & "]c:r[-1]c)"
.NumberFormat = .Offset(-1, 0).NumberFormat
End With
Range(Cells(TargetRow, 1), Cells(TargetRow, 3)).Font.Bold = True
End Sub

Private Function GetHPageBreakRow(PageBreakIndex As Long) As Long
' returns the row number for the given page break, return 0 if the given page
'break > total page breaks
' uses a temporary name and column in the active sheet to determine the correct page breaks
GetHPageBreakRow = 0
On Error Resume Next
ActiveWorkbook.Names("ASPB").Delete
On Error GoTo 0
ActiveWorkbook.Names.Add "ASPB", "=get.document(64)", False
Columns("A").Insert
Range("A1:A50").FormulaArray = "=transpose(aspb)"
On Error Resume Next
GetHPageBreakRow = Cells(PageBreakIndex, 1).Value
On Error GoTo 0
Columns("A").Delete
ActiveWorkbook.Names("ASPB").Delete
End Function
Private Sub CopyColumnWidths(TargetRange As Range, SourceRange As Range)
Dim c As Long
With SourceRange
For c = 1 To .Columns.Count
TargetRange.Columns(c).ColumnWidth = .Columns(c).ColumnWidth
Next c
End With
End Sub
Private Sub CopyRowHeights(TargetRange As Range, SourceRange As Range)
Dim r As Long
With SourceRange
For r = 1 To .Rows.Count
TargetRange.Rows(r).RowHeight = .Rows(r).RowHeight
Next r
End With
End Sub

[lucas]

Hi BexleyManor,
Take a look at this example. Second one from the bottom of the page...
creates a new workbook with subtotals at the page break....hth
http://www.erlandsendata.no/english/index.php?d=endownloadprogramming

[lucas]

austeners code is the same as my example. He was posting while I was .....

[BexleyManor]

Wow, those are some phenomenal responses!

I will try the code when I return to the office tomorrow and let you know how things go.

Hat's off and many thanks Guys, you never cease to amaze with your helpfulness. :bow:

[lucas]

I put line breaks in your code austenr, hope you don't mind as it was running off the screen.

[BexleyManor]

Folks, the code works a treat. Many, many thanks.

It also got me thinking about how I could hand control over to the user for specifying which columns to use for the subtotalling. As it is I need to delve into the code and change this manually. It would be really nice to have the user prompted for which columns to use.

Any suggestions??

[austenr]

ok Lucas

[mdmackillop]

Something like

Dim tmp1 As Long, tmp2 As Long
Sub test()
tmp1 = Columns(InputBox("Enter source column letter", , "A")).Column
tmp2 = Columns(InputBox("Enter sub-total column letter", , "C")).Column
InsertSubtotals Columns(tmp1)
End Sub


and this in Private Sub InsertSubTotal(RowIndex As Long, ....


With Cells(TargetRow, tmp2)
t = -tmp2 + 1
.Formula = "=subtotal(9,r[-" & TargetRow - PreviousPageBreak & "]c[" & t & "]:r[-1]c[" & t & "])"
.NumberFormat = .Offset(-1, 0).NumberFormat
End With