问Excel VBA将每个工作表导出到一个PDF页面中

EN

    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