Excel VBA可将基于单元格值的特定工作表导出为PDF
问题描述：
我想使用 Sheet 4 上的单元格值来选择并导出 Sheet 1 ， Sheet 2 和 Sheet 3作为一个PDF文件.
I would like to use cell values on Sheet 4 to select and export Sheet 1, Sheet 2, and Sheet 3 as one PDF file.
例如，如果 Sheet 4的是A1 = 1，A2 = 1和A3 = 0，则它将打印 Sheet 1 和 Sheet 2 ，但不是第3张.
For example, if Sheet 4's A1=1, A2=1, and A3=0, then it would print Sheet 1 and Sheet 2, but not Sheet 3.
我尝试使用IF函数创建工作表数组，但没有成功.
I tried to use the IF function to create an array of sheets, but I have not been successful.
任何帮助将不胜感激.
答
PDF格式的表格
链接
Workbook.ExportAsFixedFormat方法(Excel)(微软)
简短说明(并非100％准确)
改进的快速数组版本将源范围复制到范围数组中.通过遍历Range Array的元素，它会检查Criteria，如果找到了条件，则将适当的Sheet名称写入Sheet Array.完成后，它将调整"图纸数组并将图纸(一次完成)复制到新工作簿中，然后在关闭之前将其导出为PDF.
The Improved Fast Array Version copies the Source Range into the Range Array. By looping through the elements of the Range Array, it checks for the Criteria and if found, writes the appropriate Sheet name to the Sheet Array. When done, it 'adjusts' the Sheet Array and copies the sheets (in one go) to a new workbook, which is then exported as PDF, before it is closed.
'*******************************************************************************
' 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
'*******************************************************************************