Scriptorium

us fr nl




VBA : Printing: Printing pages with a dynamic header or footer   nl


Options: Save as PDF | Save attached file | Toggle line numbers

Details:

Type: sub
Added By: Rembo
Short Description:
Please check the improved article on my new website here:
http://www.vba-and-excel.com/vba/printing/11-printing-pages-with-a-dynamic-header-or-footer

In Excel you can set a header or footer to include dynamic data such as the pagenumber or time. However, there is no intrinsic function to add a subtotal for example. This routine shows a method for achieving such. It will calculate the sub total and grand total for a series of numbers and display them in the footer of each page.
Notes:
What basically happens here is that the routine simply generates each page on itself, changing the footer or header as needed and then prints the page before moving on to the next one.

Note that there is a bug in the creation of the HPageBreaks and VPageBreaks collection. This code uses a workaround as suggested by Microsoft.
Added: Mar 3 2006 at 11:59 AM
Modified: Jun 13 2013 at 4:21 PM
Related URLs


Usage:

To see it work fill some rows with numbers (at least enough rows to be able to
print two pages) and run the routine.


Code:

Formatted | Unformatted
  1. Sub PrintDynamicFooterHeader()
  2.  
  3. 'This routine prints pages with a running total.
  4. 'Rembo created this routine. you can find me at:
  5. 'http://scriptorium.serve-it.nl/index.php
  6. Dim rPrint() As Range, rStartCell As Range, rEndCell As Range, r As Range
  7. Dim i As Integer, iHPagebrks As Integer
  8. Dim dblGrandTotal As Double, dblSubTotal As Double
  9. 'Set PrintArea to used range
  10. Worksheets(1).PageSetup.PrintArea = Worksheets(1).UsedRange.Address
  11. 'There is an issue with the HPageBreaks and VPageBreaks collection in Excel that
  12. 'under certain circumstances causes not all the Breaks being correctly identified
  13. 'and added to the collection.
  14. 'More info at http://support.microsoft.com/default.aspx?scid=kb;en-us;210663
  15. 'This part of the code is here to circumvent that issue.
  16. '
  17. 'Select the last cell in your used range
  18. With Worksheets(1)
  19. .Cells(.UsedRange.Rows.Count + .UsedRange.Row - 1, .UsedRange.Columns.Count + .UsedRange.Column - 1).Select
  20. End With
  21. Application.ScreenUpdating = False
  22. iHPagebrks = Worksheets(1).HPageBreaks.Count
  23. 'Determine and store ranges to print
  24. ReDim rPrint(iHPagebrks + 1)
  25. For i = 1 To iHPagebrks + 1
  26. With Worksheets(1)
  27. If i = 1 Then
  28. Set rEndCell = .HPageBreaks(i).Location.Offset(-1, 0)
  29. Set rStartCell = .UsedRange.Item(1, 1)
  30. ElseIf i = iHPagebrks + 1 Then
  31. Set rEndCell = .Cells(.Rows.Count, .HPageBreaks(i - 1).Location.Column).End(xlUp)
  32. Set rStartCell = .Cells(.HPageBreaks(i - 1).Location.Row, 1)
  33. Else
  34. Set rEndCell = .HPageBreaks(i).Location.Offset(-1, 0)
  35. Set rStartCell = .HPageBreaks(i - 1).Location
  36. End If
  37. rEndCell.Activate
  38. End With
  39. Set rPrint(i) = Range(rStartCell, rEndCell)
  40. Next i
  41. 'Preview each page to print while counting the total.
  42. 'To actually print, replace the PrintPreview method with the PrintOut method.
  43. For i = 1 To UBound(rPrint)
  44. dblSubTotal = Application.WorksheetFunction.Sum(rPrint(i))
  45. dblGrandTotal = dblGrandTotal + dblSubTotal
  46. With Worksheets(1).PageSetup
  47. .PrintArea = rPrint(i).Address
  48. .RightFooter = "Sub Total: " & dblSubTotal & Chr(13) & _
  49. "Grand Total: " & dblGrandTotal
  50. End With
  51. ActiveWindow.SelectedSheets.PrintPreview
  52. Next i
  53. 'Clean up
  54. 'ReDim rPrint(1)
  55. Worksheets(1).PageSetup.RightFooter = ""
  56. Application.ScreenUpdating = True
  57. End Sub



User comments :

Add a new comment   Back to Top
Atom Feed
Contact | About This Application | Scriptorium Website