Printing selected sheets as PDF

[Jan Willem]

Hello Everyone!
I regularly follow the threads on this forum and I has found many times great solutions!
But now I need a liitle help.
I found a perfect "Walkenbach-solution" for my problem.
I have a workbook with many sheets. I want to select sheet using a selectbox (VBA) an these sheet must be printed as PDF.
I think that teh VBA-script needs a small adjustment. Who can change this script for me?
Thanks a lot!!
The script:

Sub SelectSheets()
    '   John Walkenbach
    '   [URL='http://www.j-walk.com']www.j-walk.com[/URL]
    Dim i As Integer
    Dim TopPos As Integer
    Dim SheetCount As Integer
    Dim PrintDlg As DialogSheet
    Dim CurrentSheet As Worksheet, FinalSheet As Worksheet
    Dim cb As CheckBox
    Application.ScreenUpdating = False

    Set FinalSheet = ActiveSheet
   
'   Check for protected workbook
    If ActiveWorkbook.ProtectStructure Then
        MsgBox "Workbook is protected.", vbCritical
        Exit Sub
    End If

'   Add a temporary dialog sheet
    Set CurrentSheet = ActiveSheet
    Set PrintDlg = ActiveWorkbook.DialogSheets.Add

    SheetCount = 0

'   Add the checkboxes
    TopPos = 40
    For i = 1 To ActiveWorkbook.Worksheets.Count
        Set CurrentSheet = ActiveWorkbook.Worksheets(i)
'       Skip empty sheets and hidden sheets
        If Application.CountA(CurrentSheet.Cells) <> 0 And _
            CurrentSheet.Visible Then
            SheetCount = SheetCount + 1
            PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5
                PrintDlg.CheckBoxes(SheetCount).Text = _
                    CurrentSheet.Name
            TopPos = TopPos + 13
        End If
    Next i

'   Move the OK and Cancel buttons
    PrintDlg.Buttons.Left = 240

'   Set dialog height, width, and caption
    With PrintDlg.DialogFrame
        .Height = Application.Max _
            (68, PrintDlg.DialogFrame.Top + TopPos - 34)
        .Width = 230
        .Caption = "Select sheets to print"
    End With

'   Change tab order of OK and Cancel buttons
'   so the 1st option button will have the focus
    PrintDlg.Buttons("Button 2").BringToFront
    PrintDlg.Buttons("Button 3").BringToFront

'   Display the dialog box
    CurrentSheet.Activate
    Application.ScreenUpdating = True
    If SheetCount <> 0 Then
        If PrintDlg.Show Then
            For Each cb In PrintDlg.CheckBoxes
                If cb.Value = xlOn Then
                    Worksheets(cb.Caption).Activate
                    ActiveSheet.PrintOut
'                   ActiveSheet.PrintPreview 'for debugging
                End If
            Next cb
        End If
    Else
        MsgBox "All worksheets are empty."
    End If

'   Delete temporary dialog sheet (without a warning)
    Application.DisplayAlerts = False
    PrintDlg.Delete

'   Reactivate original sheet
    FinalSheet.Activate
End Sub

 

[John_w]

Please use code tags (# icon in message editor) to preserve indentation.

Try this revised macro:

Public Sub Save_Selected_Sheets_As_PDF()
    ' John Walkenbach
    ' www.j-walk.com
    Dim i As Integer
    Dim TopPos As Integer
    Dim SheetCount As Integer
    Dim PrintDlg As DialogSheet
    Dim CurrentSheet As Worksheet, FinalSheet As Worksheet
    Dim cb As CheckBox
    Dim numSelectedSheets As Integer
    Dim PDFfileName As String
    
    Set FinalSheet = ActiveSheet
    
    ' Check for protected workbook
    If ActiveWorkbook.ProtectStructure Then
        MsgBox "Workbook is protected.", vbCritical
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    ' Add a temporary dialog sheet
    Set CurrentSheet = ActiveSheet
    Set PrintDlg = ActiveWorkbook.DialogSheets.Add
    
    SheetCount = 0
    
    ' Add the checkboxes
    TopPos = 40
    For i = 1 To ActiveWorkbook.Worksheets.Count
        Set CurrentSheet = ActiveWorkbook.Worksheets(i)
        ' Skip empty sheets and hidden sheets
        If Application.CountA(CurrentSheet.Cells) <> 0 And _
            CurrentSheet.Visible Then
            SheetCount = SheetCount + 1
            PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5
            PrintDlg.CheckBoxes(SheetCount).Text = _
            CurrentSheet.Name
            TopPos = TopPos + 13
        End If
    Next i
    
    ' Move the OK and Cancel buttons
    PrintDlg.Buttons.Left = 240
    
    ' Set dialog height, width, and caption
    With PrintDlg.DialogFrame
        .Height = Application.Max _
        (68, PrintDlg.DialogFrame.Top + TopPos - 34)
        .Width = 230
        .Caption = "Select sheets to print"
    End With
    
    ' Change tab order of OK and Cancel buttons
    ' so the 1st option button will have the focus
    PrintDlg.Buttons("Button 2").BringToFront
    PrintDlg.Buttons("Button 3").BringToFront
    
    ' Display the dialog box
    CurrentSheet.Activate
    Application.ScreenUpdating = True
    
    If SheetCount <> 0 Then
        If PrintDlg.Show Then
            numSelectedSheets = 0
            For Each cb In PrintDlg.CheckBoxes
                If cb.Value = xlOn Then
                    'Add this sheet to group
                    Worksheets(cb.Caption).Select numSelectedSheets = 0
                    numSelectedSheets = numSelectedSheets + 1
                    
                    'Original code
                    'Worksheets(cb.Caption).Activate
                    'ActiveSheet.PrintOut
                    ' ActiveSheet.PrintPreview 'for debugging
                End If
            Next cb
            
            If numSelectedSheets > 0 Then
                PDFfileName = ThisWorkbook.Path & "\Sheets.pdf"
                ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFfileName, _
                    Quality:=xlQualityMinimum, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
                MsgBox "Created PDF file " & PDFfileName
            End If

        End If
    Else
        MsgBox "All worksheets are empty."
    End If
    
    ' Delete temporary dialog sheet (without a warning)
    Application.DisplayAlerts = False
    PrintDlg.Delete
    
    ' Reactivate original sheet
    FinalSheet.Activate
    
End Sub

 

[Jan Willem]

Many thanks! It works great! Apologies for forgetting the tags. The post was gone when I realized! Next time....

 

[nisanthp]

Hi I found this solution very useful many thanks for that.

Is it possible to select a filename while saving based on a range on this or give prompt while saving.

 

[John_w]

Is it possible to select a filename while saving based on a range on this or give prompt while saving.

For the first method, replace:

PDFfileName = ThisWorkbook.Path & "\Sheets.pdf"

with:

PDFfileName = ThisWorkbook.Worksheets("Sheet1").Range("A1").Value

where Sheet1!A1, for example, contains the full PDF file name.

For the second method, replace:

    Dim PDFfileName As String

with:

    Dim PDFfileName As Variant

and:

                PDFfileName = ThisWorkbook.Path & "\Sheets.pdf"
                ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFfileName, _
                    Quality:=xlQualityMinimum, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
                MsgBox "Created PDF file " & PDFfileName

with:

                PDFfileName= Application.GetSaveAsFilename(InitialFileName:=ThisWorkbook.Path, FileFilter:="PDF (*.pdf), *.pdf", Title:="Save sheets as PDF")
                
                If PDFfileName<> False Then
                    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFfileName, _
                        Quality:=xlQualityMinimum, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
                    MsgBox "Created PDF file " & PDFfileName, vbInformation
                Else
                    MsgBox "PDF not saved", vbExclamation
                End If

InitialFileName is optional and can be set to a suitable file path and/or file name, perhaps from a cell value.