Page Footer for multiple sheets︰display current page of all sheets and also current page of that single sheet

[smallxyz]

Suppose I have 2 sheets, named "A" and "B".
If sheet "A" is printed solely, there will be 10 pages.
If sheet "B" is printed solely, there will be 5 pages.

This time, sheets "A" and "B" will be printed out together as a single PDF file.
I hope that,

for the center Page Footer, the page can display current page of all sheets,
e.g. "Page # of 15"

for the right Page Footer, the page can display current page of that sheets,
e.g. "Page # of 10 of Sheet A" or"Page # of 5 of Sheet B"

The visual result of the Footer will be something like :
Page 1 of 15　 Page 1 of 10 of Sheet A
…
Page 10 of 15　 Page 10 of 10 of Sheet A
Page 11 of 15　 Page 1 of 5 of Sheet B
…
"Page 15 of 15　 Page 5 of 5 of Sheet B

Is it possible with Excel ?

 

[John_w]

Yes, it is possible to 'print' sheets "A" and "B" as a single PDF file with the page footers in the way you describe, but in a roundabout way.

The following macro creates separate PDF files for each sheet's pages (A_1.pdf, A_2.pdf, ..., A_10.pdf, B_1.pdf, B_2.pdf, ..., B_5.pdf) with the correct page footers. These PDFs are created in the same folder as the workbook.

You will then need to use a third party tool (e.g. PDFtk Server) or a library (e.g. Adobe Acrobat API) to merge the multiple PDFs to a single PDF.

Public Sub Create_PDFs_For_Sheet_Pages()

    Dim PDFsheetNames As Variant
    Dim PDFoutputFolder As String, PDFname As String
    Dim currentSheet As Worksheet
    Dim wsName As Variant
    Dim page As Long, pageStartRow As Long
    Dim totalPages As Long, sheetPages As Long, rowsPerPage As Long, cumulativePageNum
    Dim pageRange As Range
    Dim PDFfiles As Collection
    
    'Sheets whose pages will be saved as PDF files
    
    PDFsheetNames = Array("A", "B")
    
    PDFoutputFolder = ThisWorkbook.path & "\"
    If Right(PDFoutputFolder, 1) <> "\" Then PDFoutputFolder = PDFoutputFolder & "\"
        
    Set PDFfiles = New Collection
    
    Application.ScreenUpdating = False
            
    Set currentSheet = ActiveSheet
    
    'Calculate the total number of pages in the specified sheets
    
    cumulativePageNum = 0
    totalPages = 0
    For Each wsName In PDFsheetNames
        With ThisWorkbook.Worksheets(wsName)
            .Activate
            .PageSetup.PrintArea = ""
            ActiveWindow.View = xlPageBreakPreview
            'Debug.Print .HPageBreaks.Count
            totalPages = totalPages + .HPageBreaks.Count
        End With
    Next
    
    For Each wsName In PDFsheetNames
    
        With ThisWorkbook.Worksheets(wsName)
            .Activate
            rowsPerPage = 0
            pageStartRow = 1
            sheetPages = .HPageBreaks.Count
            
            For page = 1 To sheetPages
            
                PDFname = wsName & "_" & page & ".pdf"
                cumulativePageNum = cumulativePageNum + 1
                
                If rowsPerPage = 0 Then rowsPerPage = .HPageBreaks(1).Location.Row - 1
                
                If page < sheetPages Then
                    'Set the start and end row numbers range for this page
                    Set pageRange = .Rows(pageStartRow & ":" & .HPageBreaks(page).Location.Row - 1)
                    pageStartRow = .HPageBreaks(page).Location.Row
                Else
                    'The last page doesn't end with a page break, so derive the end row from the start row of the penultimate page and the number of rows per page
                    Set pageRange = .Rows(pageStartRow & ":" & pageStartRow + rowsPerPage - 1)
                End If
                'Debug.Print cumulativePageNum, page, pageRange.Address
                
                'Set up footers for this sheet page
                
                With .PageSetup
                    .PrintArea = pageRange.Address
                    .LeftFooter = ""
                    .CenterFooter = "Page " & cumulativePageNum & " of " & totalPages
                    .RightFooter = "Page " & page & " of " & sheetPages & " of Sheet " & wsName
                End With
            
                'Save this page as a PDF
                
                pageRange.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFoutputFolder & PDFname, _
                    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
                PDFfiles.Add PDFname
                    
                .PageSetup.PrintArea = ""

            Next
            
            ActiveWindow.View = xlNormalView
            
        End With
    
    Next
    
    currentSheet.Activate
    
    Application.ScreenUpdating = True
        
    MsgBox "Now merge the following files:" & vbCrLf & vbCrLf & CollectionToString(PDFfiles, ", ")
    
End Sub


Public Function CollectionToString(coll As Collection, delim As String) As String
    Dim collItem As Variant
    Dim out As String
    CollectionToString = ""
    For Each collItem In coll
        CollectionToString = IIf(CollectionToString = "", collItem, CollectionToString & delim & collItem)
    Next
End Function