Print Unique Footer Header with Tabs

Problem:  You've been given  20 minutes to update 3 tabs of a 25 Tab *MONSTER* Spreadsheet, and REPORT your updates ....  Some are Landscape and some are Portrait.  Most are 5+ pages long.

How to make page number, sheet name and file name show in header and footer for your meeting in 20 minutes?

Sub Write_Header_Footer_from_Many_Tabbed_Workbook()
 Dim qystring, howmany, menudefault, sht
 'THIS IS FOR A XLS OF MANY TABS - sets the header, footer, and margins of each tab
 If Not ActiveWorkbook.Saved Then
 qystring = "nonemptystring"
 howmany = Sheets.Count
 Do
 menudefault = "OK to wait " & howmany * 10 & " seconds " ' Set default.
 qystring = InputBox("Wait 10 seconds each while header/footers written for " & howmany & " tabs?" _
 & vbCrLf & vbCrLf & "Enter Yes / No (or press 'Escape Key' to Skip)", "Enter Yes / No (or press 'Escape Key' to Skip)", menudefault)
 If qystring > "" Then qystring = UCase(Left(qystring, 1))
 'qystring = MsgBox(menudefault & " for " & howmany & " tabs?", vbYesNoCancel, "Write Tab Names to Header and Footer")
 Loop Until ((qystring = "N") Or (qystring = "Y") Or (qystring = "O") Or (qystring = ""))
 End If 'if not saved
 If UCase(Left(qystring, 1)) = "N" Then
 Exit Sub
' If qystring <> vbYes Then Exit Sub 'this line is if using msgbox alternative to inputbox above
 Else
 For Each sht In Sheets
 With sht.PageSetup
 .CenterHeader = "&A"
 .RightFooter = "Page &P of &N"
 .CenterFooter = "&08" & "&F" 'to show full (network) path use ' Me.Path & "/" & vbCrLf & "&F"
 .LeftFooter = "&D &T"
 .FitToPagesWide = 1
 .FitToPagesTall = 999
 .PrintTitleRows = "$1:$1"
 If (.Orientation = xlLandscape) Then
 .LeftMargin = Application.InchesToPoints(0.25)
 .RightMargin = Application.InchesToPoints(0.25)
 .TopMargin = Application.InchesToPoints(0.65)
 .BottomMargin = Application.InchesToPoints(0.65)
 .HeaderMargin = Application.InchesToPoints(0.2)
 .FooterMargin = Application.InchesToPoints(0.2)
 Else
 .LeftMargin = Application.InchesToPoints(0.5)
 .RightMargin = Application.InchesToPoints(0.5)
 .TopMargin = Application.InchesToPoints(0.5)
 .BottomMargin = Application.InchesToPoints(0.5)
 .HeaderMargin = Application.InchesToPoints(0.2)
 .FooterMargin = Application.InchesToPoints(0.2)
 End If
 End With
 Next sht
 End If ' vbyes
 
 End Sub
'--------------

1 thought on “Print Unique Footer Header with Tabs”

Leave a Reply

Your email address will not be published. Required fields are marked *