Question

以下代码检查工作表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

More code explanation here from my previous post.

Answer 1

通过在每张纸上找到数据的终点来设置打印区域。好的文档here。然后使用ExportAsFixedFormat，确保IgnorePrintAreas仍设置为False。

Answer 2

尝试一下！

' Save seperate sheets as seperate PDF files
    Sub SaveAsPDF()
    Dim CurWorksheet As Worksheet
        For Each CurWorksheet In ActiveWorkbook.Worksheets
            CurWorksheet.ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=Application.ActiveWorkbook.Path & "\" & CurWorksheet.Name, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=False
        Next CurWorksheet
    End Sub


' Save All Sheets to one single PDF File
Sub AllSheetsToOnePDF()
ThisWorkbook.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    Application.ActiveWorkbook.Path & "\" & "All.pdf",
    Quality:=xlQualityStandard, 
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, 
    OpenAfterPublish:=True
End Sub

Answer 3

如果要在一页中包含此内容，则必须将每个工作表中的每个数据复制到1个新工作表中，并清除打印区域，然后设置新的打印区域。然后将其设置为适合一页打印

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

3 个答案: