Printing selected sheets as PDF

Jan Willem

New Member
Joined
Jan 20, 2019
Messages
2
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:
VBA Code:
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
 

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,750
Please use code tags (# icon in message editor) to preserve indentation.

Try this revised macro:
Code:
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
 
Last edited:

Jan Willem

New Member
Joined
Jan 20, 2019
Messages
2
Many thanks! It works great! Apologies for forgetting the tags. The post was gone when I realized! Next time....
 

nisanthp

New Member
Joined
Jul 1, 2009
Messages
20
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

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,750
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:

VBA Code:
PDFfileName = ThisWorkbook.Path & "\Sheets.pdf"
with:
VBA Code:
PDFfileName = ThisWorkbook.Worksheets("Sheet1").Range("A1").Value
where Sheet1!A1, for example, contains the full PDF file name.

For the second method, replace:
VBA Code:
    Dim PDFfileName As String
with:
VBA Code:
    Dim PDFfileName As Variant
and:
VBA Code:
                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:
VBA Code:
                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.
 

Watch MrExcel Video

Forum statistics

Threads
1,129,433
Messages
5,636,270
Members
416,910
Latest member
zezspecs

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top