Clash Royale CLAN TAG#URR8PPP

Convert Sheets As Separate PDFs w/ Loop

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.

.PDF

.PDF

A1

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.

.PDF

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


1 Answer
1

Issues I see here:

On Error Resume Next

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


By clicking "Post Your Answer", you acknowledge that you have read our updated terms of service, privacy policy and cookie policy, and that your continued use of the website is subject to these policies.