Loop to enter email address and attach applicable pdf

Question

This code is supposed to:

1. Export the four worksheets listed in the array (dim as s) as a pdf
2. Attach that pdf to an email and add a simple generic message
3. Insert the applicable email address into the To field on the email
4. Display the email to allow the user to review it before they hit send.

It is working except for Step 3.

The problem is looping the four email addresses to load them into the “To: field” for the emails. It will assign the first email address to “strNames” but will use it until all four sheets are exported, so they all are addressed to [email protected]
Only after it exits that loop, will it cycle down to the next email address [email protected]
Because there are four email addresses and four worksheets, I end up with 16 emails when it should be four different emails each having four different applicable attachments.

When done I should have four emails on my desktop ready to send as follows:
An email addressed to “[email protected]” with attached file: 2022 02 (TED)_ABC Therapy.pdf
An email addressed to “[email protected]” with attached file: 2022 02 (TED)_Achievement Therapy.pdf
An email addressed to “[email protected]” with attached file: 2022 02 (TED)_Barb Therapy.pdf
An email addressed to “[email protected]” with attached file: 2022 02 (TED)_Felisa, Robin V..pdf

Sub PDF_to_Email_2022_03_07()

    'ActiveWorkbook.Worksheets("ABC Therapy).Select         Email for ABC Therapy is
    `"[email protected]"`
    'ActiveWorkbook.Worksheets("Achieve Therapy").Select    Email for Achieve Therapy is
    `"[email protected]"`
    'ActiveWorkbook.Worksheets("Barb Therapy").Select       Email for Barb Therapy is
    `"[email protected]"`
    'ActiveWorkbook.Worksheets("Felisa, Robin V.").Select   Email for Felisa, Robin V. is
    `"[email protected]"`    

    Dim sh As Variant
    Dim strNames(1 To 4) As String

    strNames(1) = "[email protected]"
    strNames(2) = "[email protected]"
    strNames(3) = "[email protected]"
    strNames(4) = "[email protected]"

    Dim i As Long

    For i = 1 To 4

        For Each sh In Array _
            ("ABC Therapy", "Achieve Therapy", "Barb Therapy", "Felisa, Robin V.")
    
            Sheets(sh).Select

            Dim Wb As Workbook
            Dim FileName As String
            Dim OutlookApp As Object
            Dim OutlookMail As Object
            On Error Resume Next

            Set Wb = Application.ActiveWorkbook
            FileName = Wb.FullName

            xIndex = VBA.InStrRev(FileName, ".")

            If xIndex > 1 Then FileName = VBA.Left(FileName, xIndex - 24)

            FileName = FileName & "_" + ActiveSheet.Name & ".pdf"

            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName
            Set OutlookApp = CreateObject("Outlook.Application")
            Set OutlookMail = OutlookApp.CreateItem(0)
            With OutlookMail
            
                .To = strNames(i)
        
                .CC = ""
                .BCC = ""
                .Subject = "EI Payment Report"
                .Body = "Enclosed is your monthly Report."
                .Attachments.Add FileName
                .Display

            End With
            Kill FileName
            Set OutlookMail = Nothing
            Set OutlookApp = Nothing

        Next sh
    Next i

End Sub

Answer 1

It is easy to see that you're getting 16 results (or emails) in this code because you're using two 4-time cycles. Basically your For i cycle is repeating your For each cycle four times.

What I would do is delete your For i cycle and maybe add a validation later in the code (if-then) to validate what email address to send the result to. For convenience and to keep it simple, I'll just add a counter for now.

Sub PDF_to_Email_2022_03_07()    

'ActiveWorkbook.Worksheets("ABC Therapy).Select         Email for ABC Therapy is 
`"[email protected]"`
'ActiveWorkbook.Worksheets("Achieve Therapy").Select    Email for Achieve Therapy is 
`"[email protected]"`
'ActiveWorkbook.Worksheets("Barb Therapy").Select       Email for Barb Therapy is 
`"[email protected]"`
'ActiveWorkbook.Worksheets("Felisa, Robin V.").Select   Email for Felisa, Robin V. is 
`"[email protected]"`


Dim sh As Variant
Dim strNames(1 To 4) As String
Dim counter as integer
counter=1

strNames(1) = "[email protected]"
strNames(2) = "[email protected]"
strNames(3) = "[email protected]"
strNames(4) = "[email protected]"




For Each sh In Array _
("ABC Therapy", "Achieve Therapy", "Barb Therapy", "Felisa, Robin V.")
    
Sheets(sh).Select



Dim Wb As Workbook
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
On Error Resume Next

Set Wb = Application.ActiveWorkbook
FileName = Wb.FullName

xIndex = VBA.InStrRev(FileName, ".")   


If xIndex > 1 Then FileName = VBA.Left(FileName, xIndex - 24)


FileName = FileName & "_" + ActiveSheet.Name & ".pdf"   


ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail

    
.To = strNames(counter)
counter=counter+1    
    
        
.CC = ""
.BCC = ""
.Subject = "EI Payment Report"
.Body = "Enclosed is your monthly Report." 
.Attachments.Add FileName
.Display

End With
Kill FileName
Set OutlookMail = Nothing
Set OutlookApp = Nothing


Next sh

End Sub