我想使用 Sheet 4 上的单元格值来选择并导出 Sheet 1 ， Sheet 2 和 Sheet 3 作为一个PDF文件。
例如，如果 Sheet 4的是A1 = 1，A2 = 1和A3 = 0，则它将打印 Sheet 1 和 Sheet 2 ，但不是第3张。
我试图使用IF函数创建一个工作表数组，但是没有成功。
任何帮助将不胜感激。
答案 0 :(得分：0)
Export multiple sheets to PDF simultaneously without using ActiveSheet or Select（SO）
Workbook.ExportAsFixedFormat method (Excel)（Microsoft）
VBA - Add sheets to variable and move to new workbook（SO）
简短说明（并非100％精确）
改进的快速数组版本将源范围复制到范围数组中。通过遍历Range Array的元素，它会检查Criteria并在找到后将适当的Sheet名称写入Sheet Array。完成后，它将“调整”图纸数组并将图纸（一次完成）复制到新工作簿中，然后在关闭之前将其导出为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
'*******************************************************************************