Save Each sheet to a PDF file and rename each sheet from a list of names and other criteria.

[ob1tech77]

Hello!

I was wondering if someone can help me with this task. I'm not very good at Macros. I have a file with about 150 sheets. I want to be able to save every sheet to pdf format and rename it from a list located in the worksheet. Name of file would look like this JJones-1stGP-Speech-23-24.pdf Every sheet matches the list. It would be even better if I there is some sort of button that can be pressed and it can initiate the process. I would really appreciate your help with this task.

 

[eiloken]

Amazing! This worked great. Thank you so much. You saved us a ton of work.

Let’s say I want to save the PDFs to a folder in the desktop called logs. What do I change in the code?

You can change "thisworkbooks.path" after "filename" to your destination folder

 

[eiloken]

You can change "thisworkbooks.path" after "filename" to your destination folder

or you can change the code like this, i add code to select destination folder each time you run the code:

Sub ExportSheetToPDF()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim sh As Worksheet
    Dim cll As Range, rng As Range
    Dim xName As String
    Dim i As Integer
    Dim SpecialSymbol As Variant
    Dim Sfolder As Variant
    Dim destPath As String
    Set Sfolder = Application.FileDialog(msoFileDialogFolderPicker) 'open select folder windows
    Sfolder.Title = "Select destination folder"
    If Sfolder.Show <> -1 Then Exit Sub
    destPath = Sfolder.SelectedItems(1)
    SpecialSymbol = Array("\", "/", ":", "*", "?", """", "<", ">", "|") 'special symbol that can not in the file name
    For Each sh In ThisWorkbook.Sheets
        If sh.Name Like "Student*" Then 'find sheet name start with 'Student'
            If Not IsEmpty(sh.Cells(4, 2)) Then 'skip when student name empty
                xName = sh.Cells(4, 2).Value
                For i = LBound(SpecialSymbol) To UBound(SpecialSymbol)
                    If InStr(sh.Cells(4, 2).Value, SpecialSymbol(i)) > 0 Then ' replace all special symbol in student name
                        xName = Replace(xName, SpecialSymbol(i), " ") ' my old code have some problems, it will happend if student name has more than 2 special symbol so i fix it like this
                    End If
                Next i
                sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=destPath & "\" & xName & "-1stGP-Speech-23-24.pdf", _
                Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False 'export to pdf
            End If
        End If
    Next sh
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

 

[jolivanes]

Or, change this in Post #9

.ExportAsFixedFormat xlTypePDF, ThisWorkbook.Path & "\" & Left(ws.Cells(2, 2), 1) & Trim(Split(ws.Cells(2, 2), " ")(1)) & " 1stGP-Speech-23-24" & ".pdf"

to this

.ExportAsFixedFormat xlTypePDF, CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\logs\"  & Left(ws.Cells(2, 2), 1) & Trim(Split(ws.Cells(2, 2), " ")(1)) & " 1stGP-Speech-23-24" & ".pdf"

 

[ob1tech77]

or you can change the code like this, i add code to select destination folder each time you run the code:

Sub ExportSheetToPDF()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim sh As Worksheet
    Dim cll As Range, rng As Range
    Dim xName As String
    Dim i As Integer
    Dim SpecialSymbol As Variant
    Dim Sfolder As Variant
    Dim destPath As String
    Set Sfolder = Application.FileDialog(msoFileDialogFolderPicker) 'open select folder windows
    Sfolder.Title = "Select destination folder"
    If Sfolder.Show <> -1 Then Exit Sub
    destPath = Sfolder.SelectedItems(1)
    SpecialSymbol = Array("\", "/", ":", "*", "?", """", "<", ">", "|") 'special symbol that can not in the file name
    For Each sh In ThisWorkbook.Sheets
        If sh.Name Like "Student*" Then 'find sheet name start with 'Student'
            If Not IsEmpty(sh.Cells(4, 2)) Then 'skip when student name empty
                xName = sh.Cells(4, 2).Value
                For i = LBound(SpecialSymbol) To UBound(SpecialSymbol)
                    If InStr(sh.Cells(4, 2).Value, SpecialSymbol(i)) > 0 Then ' replace all special symbol in student name
                        xName = Replace(xName, SpecialSymbol(i), " ") ' my old code have some problems, it will happend if student name has more than 2 special symbol so i fix it like this
                    End If
                Next i
                sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=destPath & "\" & xName & "-1stGP-Speech-23-24.pdf", _
                Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False 'export to pdf
            End If
        End If
    Next sh
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

I've updated about 40 workbook with this code and they are all working great. Thank you so much for your help. I'm extremely excited about the results. I appreciate your help.