Printing Subtotals on Each Page

I have a spreadsheet that is many pages long, and I want to print each page with a (totals this page), (running totals) section at the bottom. How do I set this up?

[davers5]

There are probably many ways to do this, however, your question is too vague.

Is it just one worksheet or many worksheets? How many pages total? How many columns do you want to sum? Those are just some questions to get started.

On 2002-03-05 14:48, Anonymous wrote:
I have a spreadsheet that is many pages long, and I want to print each page with a (totals this page), (running totals) section at the bottom. How do I set this up?

See whether the following (from Ole P. Erlandsen) does what you need :-

Sub TestInsertSubtotals()
If Application.International(xlCountrySetting) = 47 Then
If MsgBox("JA, lag en ny arbeidsbok med delsummer nederst på hver side." & Chr(13) & _
"NEI, ikke lag delsummer...", vbYesNo, "Sett inn delsummer nederst på hver side?") = vbNo Then Exit Sub
Else
If MsgBox("YES, create a new workbook with subtotals inserted at the bottom of each page." & Chr(13) & _
"NO, don't insert subtotals...", vbYesNo, "Insert subtotals at the bottom of each page?") = vbNo Then Exit Sub
End If
InsertSubtotals ActiveSheet.UsedRange
End Sub

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

It's just one worksheet, but many pages, like years and years of data listed one day at a time. Right now it's 455 pages long, and almost every column I'd like to total up at the bottome of every page. There's also about 50 columns. The only columns I don't need to total are the the date, and a couple columns i have set up to find errors. Thanks for any help.

On 2002-03-05 18:05, Anonymous wrote:
It's just one worksheet, but many pages, like years and years of data listed one day at a time. Right now it's 455 pages long, and almost every column I'd like to total up at the bottome of every page. There's also about 50 columns. The only columns I don't need to total are the the date, and a couple columns i have set up to find errors. Thanks for any help.

The code that was supplied to you by another poster puts the total of column C at the foot of each page.
Run the code on a test worksheet (say about 4 pages long) to see if it does what you want.
If it does, I'm sure that if you ask, someone will adjust the code for you to put totals for all the columns that you require.

On 2002-03-05 19:24, Anonymous wrote:

The code that was supplied to you by another poster puts the total of column C at the foot of each page.
Run the code on a test worksheet (say about 4 pages long) to see if it does what you want.
If it does, I'm sure that if you ask, someone will adjust the code for you to put totals for all the columns that you require.

You can download a sample workbook with the code at :-
http://www.erlandsendata.no/english/...rogramming.htm

That is exactly what i want, with perhaps a "running total" row below each subtotal, with a grand total at the end.

However, the sheet I have is almost 50 columns wide, with 37 or so needing a subtotal, I'm a little familiar with VB, but not very. Is this something I could add, or is it quite a bit of work?

The columns I need to subototal are F through AP, but not AB and AC. Thanks again for any help.

[Autolycus]

On 2002-03-06 18:27, Anonymous wrote:
That is exactly what i want, with perhaps a "running total" row below each subtotal, with a grand total at the end.

However, the sheet I have is almost 50 columns wide, with 37 or so needing a subtotal, I'm a little familiar with VB, but not very. Is this something I could add, or is it quite a bit of work?

The columns I need to subototal are F through AP, but not AB and AC. Thanks again for any help.

Try this :-

Sub TestInsertSubtotals()
If MsgBox("YES, create a new workbook with subtotals inserted at the bottom of each page." & Chr(13) & _
"NO, don't insert subtotals...", vbYesNo, "Insert subtotals at the bottom of each page?") = vbNo Then Exit Sub
InsertSubtotals ActiveSheet.UsedRange
End Sub

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"
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
Cells(TargetRow + 1, 1).Formula = "Accumulative Total"
With Cells(TargetRow, 6)
.Formula = "=sum(r[-" & TargetRow - PreviousPageBreak & "]c:r[-1]c)"
.NumberFormat = .Offset(-1, 0).NumberFormat
.Copy Range(Cells(TargetRow, 7), Cells(TargetRow, 42))
End With
With Cells(TargetRow + 1, 6)
If PreviousPageBreak = 1 Then
.Formula = "=r[-1]c"
Else
.Formula = "=r[-" & TargetRow - PreviousPageBreak + 3 & "]c+r[-1]c"
End If
.NumberFormat = .Offset(-1, 0).NumberFormat
.Copy Range(Cells(TargetRow + 1, 7), Cells(TargetRow + 1, 42))
End With
Range(Cells(TargetRow, 28), Cells(TargetRow + 1, 29)).ClearContents
Range(Cells(TargetRow, 1), Cells(TargetRow + 1, 42)).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

That's just what I wanted, thank you. The only hiccup is I get an error in this line

.Formula = "=sum(r[-" & TargetRow - PreviousPageBreak & "]c:r[-1]c)"

But everything seems to work fine, so I'm not too worried about it.

Thanks again.

[Autolycus]

On 2002-03-07 23:38, Anonymous wrote:
That's just what I wanted, thank you. The only hiccup is I get an error in this line

.Formula = "=sum(r[-" & TargetRow - PreviousPageBreak & "]c:r[-1]c)"

But everything seems to work fine, so I'm not too worried about it.

Thanks again.

That's strange. I don't get any error.
What is the error message?
Do you have any columns headers - and if so, what type of data are the headers?