subtotal at the end of printable page

[thoomas]

Hi! My problem is simple. I need a macro, which automatically adds a row at the end of every page just before page break and sums up the numbers for example in column F and puts that subtotal into this newly made row. Data>Subtotals does not work for me, since I don't need to sum up the data according to some criteria. I just want to sum everything that fits in a page. Is this possible at all? Can anybody help?

 

[ozNoz]

Sub PageSubTotals()
    Dim rngPrev As Range
    
    Set rngPrev = [F1]
    For Each hpb In ActiveSheet.HPageBreaks
        hpb.Location.Select
        Selection.EntireRow.Insert
        Selection.Offset(0, 5).FormulaR1C1 = "=SUM(R" & rngPrev.Row & "C:R" & (hpb.Location.Row - 2) & "C)"
        Set rngPrev = hpb.Location
    Next
End Sub

This is just a rough sketch solution. It assumes, among other things, that all your page breaks are hard, i.e. set by you. Excel treats hard and soft (i.e. automatic, as determined by paper size etc.) breaks differently in some situations, such as when inserting a row as we need to do here. If all your breaks are soft, change "(hpb.Location.Row - 2)" to "... - 1)" and if you have a mixture then things get tricky.
It also will not add subtotals to the bottom of the last page, but we'll assume that you have totals there already and won't worry about adding more.
If you wish this to run before you print, move the code to Workbook_BeforePrint in ThisWorkook. Note also that the rows you insert will not be deleted once your print is completed, but that this can be arranged if you need.
This should get you started, however.
Good Luck!

 

[thoomas]

Thanks for the answer...but it gives me the error "script out of range". Why is it so? I tried both, hard and soft page breaks, but always the same error. Any ideas? By the way, I'm an excel newbie, who is not so familiar with macros

 

[thoomas]

I'm still hoping for some help

 

[thoomas]

i've been struggling with the formula =INT(COUNTA($A$1:A2)/38)+1, which determines how many rows I want to see on a page. The question is: is it possible to automatically determine how many rows fit on a page after all before I print the page? I want to add a new column to the sheet where after every row there is a digit showing which page this row belongs into...Then I can add subtotals by grouping it accroding to this new column.

 

[thoomas]

I'm desperately in need for the solution. Can anyone help?

 

[btadams]

The only way I could find to do this is to first force pagebreaks and then insert rows and functions. Try this:

Sub SumAtPageBreaks()
Dim pages As Integer
Dim pageBegin As String
Dim i As Integer, q As Integer, iPBRow As Integer
Dim nRows As Integer, nPagebreaks As Integer
Dim R As Range

    ActiveSheet.ResetAllPageBreaks
    Set R = ActiveSheet.UsedRange
    'add pagebreak every 40 rows. Change to suit
    iPBRow = 40
    nRows = R.Rows.Count
    If nRows > iPBRow Then
      nPagebreaks = Int(nRows / iPBRow)
      For i = 1 To nPagebreaks
         ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=R.Cells(iPBRow * i + 1, 1)
      Next i
    End If
    'can be used in a separate macro, as I start counting the number of pagebreaks
    pages = ActiveSheet.HPageBreaks.Count
    pageBegin = "$A$1"
    Application.Calculation = xlCalculationManual
    For i = 1 To pages
        If i > 1 Then pageBegin = ActiveSheet.HPageBreaks(i - 1).Location.Address
        q = ActiveSheet.HPageBreaks(i).Location.Row
        Range("$A$" & q).EntireRow.Insert
        Range("$E$" & q).Value = "Sum"
        Range("$F$" & q).FormulaR1C1 = "=Sum(R" & q - iPBRow & "C7:R" & q - 1 & "C7)"
    Next i
    Application.Calculation = xlCalculationAutomatic
    
End Sub

 

[thoomas]

thank you btadams, this code does exactly what I need! Now I want to know is it possible to add also automatic grand total to the end of the data? I also want to trigger the macro automatically if some change has been made in a cell. Thanks again in advance

 

[thoomas]

I'm still stuck with the grand total problem. Anyone knows how to modify btadams' code to include also grand total to the end of the last subtotal? I'm also wondering how to adjust this code in order to insert 2 rows instead of 1? Thank you for any reply....

 

[Ekim]

Try the following routine from Ole P. Erlandsen, http://www.erlandsendata.no/

The macros have been amended to include a blank row between the data and the subtotals at the end of each page. The macros add a Grand Total at the end of the last page.

Note that the macros create a new workbook/worksheet containing the values from the source range in the master sheet.

Sub TestInsertSubtotals()
' by Ole P. Erlandsen, http://www.erlandsendata.no/ .

 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:"
    ' 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:
    ' ADD ONE BLANK ROW BEFORE SUB-TOTAL
    Cells(TargetRow + 1, 1).Formula = LabelText
    With Cells(TargetRow + 1, 6)
        .Formula = "=subtotal(9,r[-" & TargetRow - PreviousPageBreak & "]c:r[-1]c)"
        .NumberFormat = .Offset(-2, 0).NumberFormat
    End With
    Range(Cells(TargetRow + 1, 1), Cells(TargetRow, 6)).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

HTH

Mike