Convert Sheets As Separate PDFs w/ Loop

Question

I am looking for feedback on my code. It is currently working in my test environment and I wanted to see if anyone could find any flaws in the code that may cause trouble for the user.

The purpose of this code is, to convert each sheet as its own .PDF and have it saved down in a folder for a given condition. I'm first prompted where I want to save the .PDFs then, I use an if function to scan cell A1 (I plan on changing this in the future) for an email address. These will be the sheets I want to convert.

I've added a fail safe so previous .PDFs can't be overwritten without the user knowing. Once all applicable sheets are converted, it's finished.

Sub SaveSheetsAsPDF()
    Dim DestFolder As String
    Dim PDFFile As String
    Dim wb As Worksheet
    Dim AlwaysOverwritePDF As Boolean

    'Speed up macro
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    'Prompt for file destination
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            DestFolder = .SelectedItems(1)
        Else
            MsgBox "You must specify a folder to save the PDF into." & _
                vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, _
                "Must Specify Destination Folder"
            Exit Sub
        End If
    End With

    'Create new PDF file name including path and file extension
    For Each wb In ThisWorkbook.Worksheets
        'Test A1 for a mail address
        If wb.Range("A1").Value Like "?*@?*.?*" Then
            PDFFile = DestFolder & Application.PathSeparator & wb.Name & _
                "-" & Format(Date, "mmyy") & ".pdf"
            'If the PDF already exists
            If Len(Dir(PDFFile)) > 0 Then
                If AlwaysOverwritePDF = False Then
                    OverwritePDF = MsgBox(PDFFile & " already exists." & _
                        vbCrLf & vbCrLf & "Do you want to overwrite it?", _
                        vbYesNo + vbQuestion, "File Exists")
                    On Error Resume Next
                    'If you want to overwrite file then delete current one
                    If OverwritePDF = vbYes Then
                        Kill PDFFile
                    Else
                        MsgBox "OK then, if you don't overwrite the " & _
                            "existing PDF, I can't continue." & vbCrLf _
                            & vbCrLf & "Press OK to exit this macro.", _
                            vbCritical, "Exiting Macro"
                        Exit Sub
                    End If
                Else
                    On Error Resume Next
                    Kill PDFFile
                End If
                If Err.Number <> 0 Then
                    MsgBox "Unable to delete existing file.  Please make " & _
                        "sure the file is not open or write protected." _
                        & vbCrLf & vbCrLf & "Press OK to exit this macro.", _
                        vbCritical, "Unable to Delete File"
                    Exit Sub
                End If
            End If
        End If
        'Print PDF
        wb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, OpenAfterPublish:=False
    Next wb
    MsgBox "All Files Have Been Converted!"

ResetSettings:
    'Resets optimization settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Answer 1

Issues I see here:

• The lack of resetting error handling after On Error Resume Next
• Readability will be vastly improved by indentation and removing excess white space
• Clutter. Separating out the File Deletion makes the main logic flow clearer
• You might want to rethink the workflow. Do you really want the user to get halfway through (and maybe have deleted some files) the exit?
• Undeclared variables. Add Option Explicit to catch that

---

Option Explicit


Sub SaveSheetsAsPDF()
    Dim DestFolder As String
    Dim PDFFile As String
    Dim ws As Worksheet  '<~~ use a more meaningful name
    Dim AlwaysOverwritePDF As Boolean
    Dim FileDate As String

    'Speed up macro
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    'Prompt for file destination
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            DestFolder = .SelectedItems(1) & Application.PathSeparator '<~~ avoids repeating some logic
        Else
            MsgBox "You must specify a folder to save the PDF into." & _
              vbCrLf & vbCrLf & _
              "Press OK to exit this macro.", _
              vbCritical, "Must Specify Destination Folder"
            Exit Sub
        End If
    End With

    'Create new PDF file name including path and file extension
    FileDate = "-" & Format(Date, "mmyy") & ".pdf" '<~~ avoids repeating some logic
    AlwaysOverwritePDF = False '<~~~~ or True, or prompt the user, up to you

    For Each ws In ThisWorkbook.Worksheets
        'Test A1 for a mail address
        If ws.Range("A1").Value Like "?*@?*.?*" Then '<~~ may not be fully robust
            PDFFile = DestFolder & ws.Name & FileDate

            'If the PDF already exists
            If CheckDeleteFile(PDFFile, AlwaysOverwritePDF) Then
                'PDF doesn't exist (any more)

                'Prints PDF
                '<~~~~ probably want this inside the If email
                ws.ExportAsFixedFormat _
                  Type:=xlTypePDF, _
                  Filename:=PDFFile, _
                  Quality:=xlQualityStandard, _
                  IncludeDocProperties:=True, _
                  IgnorePrintAreas:=False, _
                  OpenAfterPublish:=False
            Else
                ' Sheet was skipped, what now?
            End If
        End If
    Next ws
    MsgBox "All Files Have Been Converted!"

ResetSettings:
    'Resets optimization settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
Exit Sub
EH:
    MsgBox "Unexpected Error", Err.Description
    'Add any error handling here
    Resume ResetSettings
End Sub