create and store pdf, attach to email and send, with loop

[tkellymd]

I have a workbook with multiple sheets. I need to create a pdf, save to a file, append pdf to email, then email some of the sheets with an email address in cell E1 (merged cell). This is the macro I have pieced together so far. It is stuck on the CurrentYear definition which I don't understand. The year is coming form cell M1 (non-merged) in each worksheet. Any help would be appreciated. I know very little about macros or VBA.

I have attached the macro since for some reason when included in my post, the post is denied for too many URL's or forbidden words....even though there are no URL or forbidden words in the macro.

[mdmackillop]

Minor fixes. Untested but now compiles
Dim Current year
Dest folder set as text
Next sh added


Option Explicit

Sub create_and_email_pdf()
Dim sh As Worksheet
Dim EmailSubject As String, EmailSignature As String
Dim CurrentMonth As String, DestFolder As String, PDFFile As String
Dim Email_To As String, Email_CC As String, Email_BCC As String
Dim OpenPDFAfterCreating As Boolean, AlwaysOverwritePDF As Boolean, DisplayEmail As Boolean
Dim OverwritePDF As VbMsgBoxResult
Dim OutlookApp As Object, OutlookMail As Object
Dim CurrentYear

' *****************************************************
' ***** You Can Change These Variables *********

EmailSubject = "Performance Improvement Bonus Calculation " 'Change this to change the subject of the email. The current month is added to end of subj line
OpenPDFAfterCreating = False 'Change this if you want to open the PDF after creating it : TRUE or FALSE
AlwaysOverwritePDF = False 'Change this if you always want to overwrite a PDF that already exists :TRUE or FALSE
DisplayEmail = True 'Change this if you don't want to display the email before sending. Note, you must have a TO email address specified for this to work
Email_To = sh.Range("E1").Value 'Change this if you want to specify To email e.g. ActiveSheet.Range("H1") to get email from cell H1
Email_CC = ""
Email_BCC = ""

' ******************************************************

For Each sh In ThisWorkbook.Worksheets
If sh.Range("E1").Value Like "?*@?*.?*" Then
'Set file destination
DestFolder = "C:\Users\tkell\OneDrive\GHA Critical Care\Administrative\Human Resources\Bonuses\Bonus Calculations"
'Current year stored in M1
CurrentYear = Mid(sh.Range("M1").Value, InStr(1, sh.Range("M1").Value, " ") + 1)
'Create new PDF file name including path and file extension
PDFFile = DestFolder & Application.PathSeparator & sh.Name _
& "_" & CurrentYear & ".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 the file then delete the 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
'Create the PDF
sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=OpenPDFAfterCreating
'Create an Outlook object and new mail message
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
'Display email and specify To, Subject, etc
With OutlookMail
.Display
.To = Email_To
.CC = Email_CC
.BCC = Email_BCC
.Subject = EmailSubject & CurrentMonth
.Body -"Attached is your Perfomance Improvement bonus calculation for the current period. If you have any questions I would be happy to discuss them with you."
.Attachments.Add PDFFile
If DisplayEmail = False Then
.Send
End If
End With
End If
Next sh
End Sub

[tkellymd]

When I run this macro I get a runtime error 91 for the line Email_To = sh.Range("E1"). E1 is the correct cell to look for an email address in each tab.

[tkellymd]

When I substitute Email_To = sh.Range("E1") with Email_To = ActiveSheet.Range("E1") the macro works but attaches all the pdf to a separate email but all addressed to the same Activesheet email address. How do I get it to insert the correct email (E1 for that worksheet)?

[mdmackillop]

You need to set sh to refer to a sheet before it can be used e.g. Set sh = ActiveSheet

[tkellymd]

Yes but how do set it to refer to the correct sheet, i.e. the email is the correct one for each sheet? When I tried ActiveSheet it inserted the same email address into all emails.

[mdmackillop]

For Each sh In ThisWorkbook.Worksheets
If sh.Range("E1").Value Like "?*@?*.?*" Then
Email_To = sh.Range("E1").Value

[tkellymd]

Got it to work by removing the Email_To set statement and putting Email_To: sh.Range("E!") at the bottom inside the loop. Thank you all for your help. This will really make my life simpler.