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.