Excel VBA 將基於單元格值的特定工作表導出到 PDF

Question

我想將Sheet 4上的單元格值用於 select 並將Sheet 1 、 Sheet 2和Sheet 3作為一個 PDF 文件導出。

例如，如果工作表 4 的A1=1、A2=1 和 A3=0，則它將打印工作表 1和工作表 2 ，但不打印工作表 3 。

我嘗試使用 IF function 創建工作表數組，但沒有成功。

任何幫助，將不勝感激。

Answer 1

表格為PDF

鏈接

同時將多個圖紙導出為PDF，而無需使用ActiveSheet或Select （SO）

Workbook.ExportAsFixedFormat方法（Excel） （Microsoft）

VBA-將工作表添加到變量並移動到新工作簿 （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
'*******************************************************************************

Answer 2

你不需要創建一個新的工作簿

ReDim 保留 vntS(iTarget) 之后

只需添加

  Sheets(vntS).Select
  ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=cExport, OpenAfterPublish:=True, IgnorePrintAreas:=False

你完成了

這樣你就可以保留你使用的所有 me 宏。 否則你可能會遇到錯誤，因為你沒有攜帶宏。