Excel VBA export each sheet into one PDF page

Question

The following code checks cell values on Sheet 4 to select and export Sheet 1, Sheet 2, and Sheet 3 as one PDF file.

For example, if Sheet 4's A1=1, A2=1, and A3=0, then it prints Sheet 1 and Sheet 2, but not Sheet 3.

Now, I want to make it so that each exported sheet fits on one PDF page. I added For loop and .PageSetup.FitToPageTall = 1 and .PageSetup.FitToPageWide = 1, but it still saves each sheet over multiple pages.

How would I adjust the code to make each sheet fit into one PDF page?

    Sub SheetsAsPDF()

Const cSheets As String = "Sheet1C,Sheet2A,Sheet3B"    ' Sheet List
Const cSheet As String = "Sheet4"                   ' Source Worksheet
Const cRange As String = "A1:A3"                    ' Source Range Address
Const cCrit As Long = 1                             ' Criteria
Const cExport As String = "Eport1.pdf"               ' Export Filename

Dim wb As Workbook    ' Export Workbook
Dim Cell As Range     ' Current Cell Range (For Each Control Variable)
Dim vntS As Variant   ' Sheet Array
Dim vntR As Variant   ' Range Array
Dim i As Long         ' Range Array Element (Row) Counter
Dim iTarget As Long   ' Target Element (Row) Counter

' **********************************
' Copy Sheets to New workbook.
' **********************************

' Reset Target Counter.
iTarget = -1

' Copy (split) sheet names from Sheet List to 1D 0-based Sheet Array.
vntS = Split(cSheets, ",")

' Copy Source Range in Source Worksheet to 2D 1-based 1-column Range Array.
vntR = ThisWorkbook.Worksheets(cSheet).Range(cRange)
' Loop through elements (rows) of Range Array (in its first (only) column).
' Note: Not obvious, one might say that the elements (rows) of Sheet Array
' are 'also being looped', but the counter is by 1 less.
For i = 1 To UBound(vntR)
    ' Check if current value in Range Array (vntR) is equal to Criteria
    ' (cCrit). Range Array is 2D (,1).
    If vntR(i, 1) = cCrit Then  ' Current value is equal to Criteria.
        ' Counter (add 1 to) Target Counter (iTarget).
        iTarget = iTarget + 1
        ' Write value of current element (row) of Sheet Array to the
        ' 'iTarget-th' element (row). Note: Values are being overwritten.
        ' Remarks
          ' Sheet Array is a zero-based array i.e. the index number of its
          ' first element is 0, NOT 1. Therefore i - 1 has to be used,
          ' which was previously indicated with 'also being looped'.
          ' Trim is used to avoid mistakes if the Sheet Name List is not
          ' properly written e.g. "Sheet1, Sheet2,Sheet3,  Sheet4".
        vntS(iTarget) = Trim(vntS(i - 1))
      'Else                      ' Current value is NOT equal to Criteria.
    End If
Next ' Element (row) of Range Array (vntR).
' Check if there were any values that were equal to Criteria (cCrit) i.e.
' if there are any worksheets to export.
If iTarget = -1 Then Exit Sub
' Resize Sheet Array to the value (number) of Target Counter (iTarget).
ReDim Preserve vntS(iTarget) ' Note: Values are being deleted.
' Copy sheets of Sheet Array to New Workbook.
' Remarks
  ' When Copy (for copying sheets) is used without arguments, it will copy
  ' a sheet (array) to a NEW workbook.
ThisWorkbook.Sheets(vntS).Copy

' **********************************
' Export New Workbook to PDF
' **********************************

' Create a reference (wb) to New Workbook which became the ActiveWorkbook
' after it had previously been 'created' using the Copy method.
Set wb = ActiveWorkbook
' In New Workbook

Dim ws As Worksheet

For Each ws In wb.Worksheets
           ws.PageSetup.LeftMargin = Application.InchesToPoints(0)
           ws.PageSetup.RightMargin = Application.InchesToPoints(0)
           ws.PageSetup.TopMargin = Application.InchesToPoints(0)
           ws.PageSetup.BottomMargin = Application.InchesToPoints(0)
           ws.PageSetup.HeaderMargin = Application.InchesToPoints(0)
           ws.PageSetup.FooterMargin = Application.InchesToPoints(0)
           ws.PageSetup.Orientation = xlLandscape
           ws.PageSetup.CenterHorizontally = True
           ws.PageSetup.CenterVertically = True
           ws.PageSetup.FitToPagesTall = 1
           ws.PageSetup.FitToPagesWide = 1
Next ws

With wb

    ' Export New Workbook to PDF.

    wb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=cExport, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, OpenAfterPublish:=True
    ' Close New Workbook. False suppresses the message that asks for
    ' saving it.
    wb.Close SaveChanges:=False
    ' Remarks:
    ' Change this if you might want to save this version of New Workbook
    ' e.g.
    'wb.SaveAs "WB" & Format(Date, "yyyymmdd") & ".xls"
End With
End Sub

More code explanation here from my previous post.

score 0 · Accepted Answer · answered Feb 21 '19 at 20:09

0

Set the print area by finding the end point of your data on each sheet. Good documentation here. Then use the ExportAsFixedFormat, making sure IgnorePrintAreas is still set to False.

answered Feb 21 '19 at 20:09

healey

314
1
12

I tried using `PrintArea` with `FitToPagesTall = 1` and `FitToPagesWide = 1`, but it still prints each sheet to multiple pages of PDF. It's almost as if the `FitToPage` commands are being ignored (and yes, `IgnorePrintAreas` is set to False). Any guidance on how to make it fit into one page? – Paul Lim Feb 21 '19 at 21:23
I solved it! I was missing `PageSetup.Zoom = False` Thank you for the idea and the link! – Paul Lim Feb 21 '19 at 21:31
Glad I could help! – healey Feb 21 '19 at 22:20

ASH · Answer 2 · 2019-02-21T23:01:23.117

Try it this way!!

' Save seperate sheets as seperate PDF files
    Sub SaveAsPDF()
    Dim CurWorksheet As Worksheet
        For Each CurWorksheet In ActiveWorkbook.Worksheets
            CurWorksheet.ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=Application.ActiveWorkbook.Path & "\" & CurWorksheet.Name, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=False
        Next CurWorksheet
    End Sub


' Save All Sheets to one single PDF File
Sub AllSheetsToOnePDF()
ThisWorkbook.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    Application.ActiveWorkbook.Path & "\" & "All.pdf",
    Quality:=xlQualityStandard, 
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, 
    OpenAfterPublish:=True
End Sub

@ryguy82 This gives me series of PDFs. I am trying to create one PDF with all pages on one. Also, how would this fit each sheet to one PDF page? — Paul Lim, Feb 21 '19 at 21:16
Ah, I see. I just updated my answer. instead of looping through each sheet and saving each as a separate PDF file, save all sheets in an array, in one go, as a PDF file. — ASH, Feb 21 '19 at 23:02

score 0 · Answer 3 · answered Feb 21 '19 at 20:35

0

if you want to have this in 1 page, you have to copy each data from each worksheet to 1 new sheet and clear the print area and then set the new print area. then set it to print to fit to 1 page

answered Feb 21 '19 at 20:35

jonrizz

94
4

I tried using `PrintArea` with `FitToPagesTall = 1` and `FitToPagesWide = 1`, but it still prints each sheet to multiple pages of PDF. It's almost as if the `FitToPage` commands are being ignored (and yes, `IgnorePrintAreas` is set to False). Any guidance on how to make it fit into one page? – Paul Lim Feb 21 '19 at 21:24
I solved it! I was missing `PageSetup.Zoom = False` Thank you for your help! – Paul Lim Feb 21 '19 at 21:31

Excel VBA export each sheet into one PDF page

3 Answers3