PDF 格式的表格
Links
同时将多张工作表导出为 PDF，无需使用 ActiveSheet 或 Select https://stackoverflow.com/questions/22796286/export-multiple-sheets-to-pdf-simultaneously-without-using-activesheet-or-select (SO)
Workbook.ExportAsFixedFormat 方法 (Excel) https://learn.microsoft.com/en-us/office/vba/api/excel.workbook.exportasfixedformat（微软）
VBA - 将工作表添加到变量并移动到新工作簿 https://stackoverflow.com/questions/52058318/vba-add-sheets-to-variable-and-move-to-new-workbook (SO)
简短描述（并非 100% 精确）
改进的快速数组版本将源范围复制到范围数组中。通过循环范围数组的元素，它检查条件，如果找到，则将适当的工作表名称写入工作表数组。完成后，它会“调整”工作表数组并将工作表（一次性）复制到新工作簿，然后在关闭之前将其导出为 PDF。
改进的快速阵列版本
'*******************************************************************************
' Purpose: In a workbook, exports sheets that meet criteria as PDF.
'*******************************************************************************
Sub SheetsAsPDF()
Const cSheets As String = "Sheet1,Sheet2,Sheet3" ' 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 = "Eport.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
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 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
'*******************************************************************************
第一个慢速范围/工作表版本
'*******************************************************************************
' Purpose: In a workbook, exports sheets that meet criteria to PDF.
'*******************************************************************************
Sub SheetsToPDF()
Const cESheets As String = "Sheet1,Sheet2,Sheet3" ' Sheet Name List
Const cSheet As String = "Sheet4" ' Source Worksheet
Const cRange As String = "A1:A3" ' Source Range Address
Const cCrit As Long = 1 ' Criteria
Dim wb As Workbook ' Export Workbook
Dim Cell As Range ' Current Cell Range (For Each Control Variable)
Dim vntS As Variant ' Sheet Name Array
Dim iFound As Long ' Found Criteria Counter
' **********************************
' Copy Sheets to New workbook.
' **********************************
' Copy (split) worksheet names from Sheet Name List to Sheet Name Array.
vntS = Split(cESheets, ",")
' In Source Workbook (ThisWorkbook)
With ThisWorkbook
' Loop through cells (Cell) in Source Range (.Range(cRange)).
For Each Cell In .Worksheets(cSheet).Range(cRange)
' Check if Current Cell Range (Cell) meets Criteria (cCrit).
If Cell.Value = cCrit Then ' Cell that meets Criteria was found.
' Add 1 to Found Criteria Counter (iFound).
iFound = iFound + 1
' Check if New Workbook already exists.
If iFound = 1 Then ' Used only the first time.
' Copy sheet with the sheet name found in Sheet Name Array
' to New Workbook.
' Remarks
' When Copy (for copying sheets) is used without
' arguments, it will copy a sheet to a new workbook,
' where it will be the only sheet.
' Sheet Name Array is a zero-based array, meaning the
' index number of its first element is 0, NOT 1.
' Therefore iFound-1 has to be used.
' Trim is used to avoid mistakes if the Sheet Name List
' is not properly written e.g.
' "Sheet1, Sheet2,Sheet3, Sheet4".
.Sheets(Trim(vntS(iFound - 1))).Copy
' Create a reference (wb) to New Workbook which became
' the ActiveWorkbook after the previous Copy method
' 'had created it'.
Set wb = ActiveWorkbook
Else ' Used every time, except the first time.
' Since the New Workbook has already been created (i>1),
' worksheets can be added to it:
' Copy current sheet after last sheet
' (wb.Sheets(wb.Sheets.Count)) in New Workbook.
.Sheets(Trim(vntS(iFound - 1))).Copy _
After:=wb.Sheets(wb.Sheets.Count)
End If
'Else ' Cell that meets Criteria NOT found.
End If
Next
End With
' **********************************
' Export New Workbook to PDF
' **********************************
' Check if there were any (iFound) cells that met the criteria (cCrit)
' iFound.e. if there are any worksheets to export.
If iFound = 0 Then Exit Sub
' In New Workbook
With wb
' Export New Workbook to PDF.
.ExportAsFixedFormat Type:=xlTypePDF, Filename:="Exported.pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
' Close New Workbook. False suppresses the message for saving it.
.Close False
' Remarks:
' Change this if you might want to save this version of New Workbook
' e.g.
'.SaveAs "WB" & Format(Date, "yyyymmdd") & ".xls"
End With
End Sub
'*******************************************************************************
