VBA to print worksheet to PDF and name each page individually

[DDT123]

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!

 

[John_w]

Try this macro - it expects the scorecards sheet to be named "Scorecards".

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