Excel VBA to export specific sheets based on cell

Question

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.

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.

I tried to use the IF function to create an array of sheets, but I have not been successful.

Any help would be appreciated.

Answer 1

Sheets As PDF

Links

Export multiple sheets to PDF simultaneously without using ActiveSheet or Select (SO)

Workbook.ExportAsFixedFormat method (Excel) (Microsoft)

VBA - Add sheets to variable and move to new workbook (SO)

Short Description (not 100% precise)

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.

Improved Fast Array Version

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

First Slow Range/Worksheet Version

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