excel - Excel VBA 将每张工作表导出到一个 PDF 页面
问题描述
以下代码检查工作表 4 上的单元格值,以选择工作表 1、工作表 2 和工作表 3 并将其导出为一个 PDF 文件。
例如,如果工作表 4 的 A1=1、A2=1 和 A3=0,则打印工作表 1 和工作表 2,但不打印工作表 3。
现在,我想让每个导出的工作表都适合一个 PDF 页面。我添加了 For 循环和 .PageSetup.FitToPageTall = 1 和 .PageSetup.FitToPageWide = 1,但它仍然将每张纸保存在多个页面上。
我将如何调整代码以使每张纸适合一个 PDF 页面?
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
解决方案
如果你想在 1 页中有这个,你必须将每个工作表中的每个数据复制到 1 个新工作表并清除打印区域,然后设置新的打印区域。然后将其设置为打印以适合 1 页
推荐阅读
- r - ShinyDashboard 无法创建动态绘图
- python - 如何使用子进程保存输出并在终端中查看输出?
- openlayers - OpenLayers 跳过加载高于特定分辨率的矢量特征
- haskell - Haskell 无论是主要
- c++ - 为什么多进程 C++ gRPC 服务器不起作用?
- android - 如何在单击“onbackpressed”时将动画添加到片段
- node.js - Solidity (solc) 编译挑战
- r - 添加与删除交互改变了 lm() 中单个预测变量的重要性
- nginx - 托管在 nginx 上的 .net core 3.1 web api 适用于 http POST,但不适用于 HTTPS
- pandas - 有没有办法用我已经制作的图创建图表网格?