Autosumming

The following is from Ole P. Anderson. Not tested.

' macros written 19991110 by Ole P. Erlandsen, ope@st.telia.no
Option Explicit

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