Macro to Print Multiple Sheets to Single PDF

**LEber** · 09-06-2013, 10:23 AM

I know there are many threads out there similar to this one, however, I have not quite found one to fit my situation. With my limited coding skills (self taught out of necessity), I am challenged on this one. I have code that creates a dialog box for the users to select which sheets to print (workbook sheets can change). This works great and adapts as sheets are added and prints to the printer just as designed. However, I now need to be able to do this same thing but print to a PDF - I can get it to print each selected sheet individually to a single PDF, but need it to not only print to PDF, but to consolidate the selected sheets into a single PDF file.

I have attached my original code that prints to a standard printer. Any help on taking this in a new direction would be greatly appreciated. I apologize in advance for my non-technical background!

Thanks.

Sub PrintMacro()
   'Credit Only Option
    Dim i As Integer
    Dim TopPos As Integer
    Dim SheetCount As Integer
    Dim PrintDlg As DialogSheet
    Dim CurrentSheet As Worksheet
    Dim cb As CheckBox
    Application.ScreenUpdating = False

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

                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
    ActiveWorkbook.Worksheets("Instructions and Printing").Select
End Sub

**patel45** · 09-06-2013, 12:06 PM

Sub exportSomeSheetsTo1Pdf()
    Dim mySheets As Sheets
    Dim SaveToPath As String
    Set mySheets = Worksheets(Array("Sheet1", "Sheet2")) ' to be changed
    filenameSave = "C:\test\myfile.pdf" ' to be changed
    With ConsolidationSheet(mySheets, "")
        .ExportAsFixedFormat Type:=xlTypePDF, Filename:=filenameSave, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
    End With
End Sub
Function ConsolidationSheet(mySheets As Sheets, Optional SheetHeader As Variant) As Worksheet
    Dim tempSheet As Worksheet
    Dim StartNewSheetRow As Long, StartNewSheetCell As Range
    Dim i As Long
    With mySheets(1).Parent
        Set tempSheet = .Worksheets.Add(Before:=.Sheets(1))
    End With
    
    For i = 1 To mySheets.Count
        StartNewSheetRow = ReallyUsedRange(tempSheet).Rows.Count + 1
        Set StartNewSheetCell = tempSheet.Cells(StartNewSheetRow, 1)
        Select Case TypeName(SheetHeader)
            Case "String"
                If SheetHeader = vbNullString Then
                    tempSheet.Cells(StartNewSheetRow, 1).Value = mySheets(i).Name
                Else
                    tempSheet.Cells(StartNewSheetRow, 1).Value = SheetHeader
                End If
            Case "Range"
                tempSheet.Cells(StartNewSheetRow, 1).Value = mySheets(i).Range(SheetHeader.Cells(1, 1).Address).Text
        End Select
        StartNewSheetRow = ReallyUsedRange(tempSheet).Rows.Count + 1
        
        ReallyUsedRange(mySheets(i)).Copy Destination:=tempSheet.Cells(StartNewSheetRow, 1)
        tempSheet.HPageBreaks.Add Before:=StartNewSheetCell
    Next i
    tempSheet.Rows(1).Delete
    Set ConsolidationSheet = tempSheet
End Function

**LEber** · 09-06-2013, 01:14 PM

First - thank you very much. I cannot get the code to work. I think I figured out how to insert the code into what I had already put together. However, I have had several errors. The latest error is "object does not support this property or method". Any thoughts?

**patel45** · 09-07-2013, 04:09 AM

Originally Posted by LEber

First - thank you very much. I cannot get the code to work. I think I figured out how to insert the code into what I had already put together. However, I have had several errors. The latest error is "object does not support this property or method". Any thoughts?

I forgot a function

Function ReallyUsedRange(aSheet As Worksheet) As Range
    Dim lastRow As Long, lastColumn As Long
    Dim i As Long
    With aSheet
        lastRow = 0
        For i = 1 To .UsedRange.Columns.Count + .UsedRange.Column
            lastRow = Application.Max(.Cells(.Rows.Count, i).End(xlUp).Row, lastRow)
        Next i
        lastColumn = 0
        For i = 1 To lastRow
            lastColumn = WorksheetFunction.Max(.Cells(i, .Columns.Count).End(xlToLeft).Column, lastColumn)
        Next i
        Set ReallyUsedRange = .Range("A1").Resize(lastRow, lastColumn)
    End With
End Function

see attached sample