Excel VBA экспортирует каждый лист в одну страницу PDF

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

Более подробное объяснение кода здесь из моего предыдущего поста.

Answer 1

Попробуй это так !!

' 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 2

Если вы хотите, чтобы это было на 1 странице, вы должны скопировать все данные с каждого рабочего листа на 1 новый лист и очистить область печати, а затем установить новую область печати.затем установите его для печати, чтобы соответствовать 1 странице

Answer 3

Установите область печати, найдя конечную точку ваших данных на каждом листе.Хорошая документация здесь .Затем используйте ExportAsFixedFormat, убедившись, что IgnorePrintAreas по-прежнему установлен на False.