Thanks Thanks:  0
Likes Likes:  0
Page 1 of 2 12 LastLast
Results 1 to 10 of 13

Thread: Printing Subtotals on Each Page

  1. #1
    Guest

    Default

    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?

  2. #2
    Board Regular
    Join Date
    Feb 2002
    Posts
    255
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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.

  3. #3
    Guest

    Default

    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

  4. #4
    Guest

    Default

    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.

  5. #5
    Guest

    Default

    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.

  6. #6
    Guest

    Default

    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

  7. #7
    Guest

    Default

    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.


  8. #8

    Join Date
    Feb 2002
    Posts
    39
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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

  9. #9
    Guest

    Default

    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.

  10. #10

    Join Date
    Feb 2002
    Posts
    39
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default

    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?

Some videos you may like

User Tag List

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •