VBA to print worksheet to PDF and name each page individually

DDT123

New Member
Joined
Aug 9, 2011
Messages
13
Office Version
  1. 365
Platform
  1. Windows
Greetings, I have 2 worksheets, one worksheet is a supervisor's name, and the other worksheet includes scorecards for each of the supervisor's agents. On the supervisor worksheet I'm wanting to include a "Print Scorecards to PDF" button that will pop up a window asking the user which path they want to save the PDF files to. Once the user selects the path, the VBA will go to the scorecards worksheet and print each page and name them individually. So Page 1 in the print area would look at the agent's name in cell C4 and save as "[C4] - Scorecard for [C6].PDF" NOTE: Cell C6 includes a date.
Then it will repeat for Page 3 (agent's name in cell C54), Page 4 (agent's name in cell C104), etc. on that same worksheet.

Can anyone help out with the code to achieve this? Thank you in advance!
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,083
Try this macro - it expects the scorecards sheet to be named "Scorecards".
VBA Code:
Public Sub Create_Scorecards_PDFs()

    Dim currentSelection As Range
    Dim saveInFolder As String
    Dim pageStartRow As Long, page As Long
    Dim pageRange As Range
    Dim PDFfile As String
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select PDFs destination folder"
        .InitialFileName = ThisWorkbook.Path
        If .Show Then
            saveInFolder = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With
        
    Application.ScreenUpdating = False
    
    Set currentSelection = Selection
    
    With Worksheets("Scorecards")
        
        'Select last cell in print area so that Excel recalculates automatic page breaks. Can prevent "Subscript out of range" error when looping through HPageBreaks
        .Activate
        .Cells(.Range(.PageSetup.PrintArea).Rows.Count, .Range(.PageSetup.PrintArea).Column).Select
        
        pageStartRow = 1
        For page = 1 To .HPageBreaks.Count
            PDFfile = saveInFolder & .Cells(pageStartRow + 3, "C").Value & " - Scorecard for " & Format(.Cells(pageStartRow + 5, "C").Value, "YYYY-MM-DD") & ".pdf"
            Set pageRange = Intersect(.Rows(pageStartRow & ":" & .HPageBreaks(page).Location.Row - 1).EntireRow, .Range(.PageSetup.PrintArea))
            pageRange.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFfile, _
                Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
            pageStartRow = .HPageBreaks(page).Location.Row
        Next
        
    End With
    
    currentSelection.Worksheet.Activate
    currentSelection.Select
   
    MsgBox "Done"
    
    Application.ScreenUpdating = True
   
End Sub
 

Forum statistics

Threads
1,147,566
Messages
5,741,864
Members
423,692
Latest member
Bhanu1988

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