Loop to enter email address and attach applicable pdf

This code is supposed to:

Export the four worksheets listed in the array (dim as s) as a pdf
Attach that pdf to an email and add a simple generic message
Insert the applicable email address into the To field on the email
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 ABC@gmail.com
Only after it exits that loop, will it cycle down to the next email address Achieve@gmail.com
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 “ABC@gmail.com” with attached file: 2022 02 (TED)_ABC Therapy.pdf
An email addressed to “Achieve@gmail.com” with attached file: 2022 02 (TED)_Achievement Therapy.pdf
An email addressed to “Barb@gmail.com” with attached file: 2022 02 (TED)_Barb Therapy.pdf
An email addressed to “Robin@yahoo.com” 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
    `"ABC@gmail.com"`
    'ActiveWorkbook.Worksheets("Achieve Therapy").Select    Email for Achieve Therapy is
    `"Achieve@gmail.com"`
    'ActiveWorkbook.Worksheets("Barb Therapy").Select       Email for Barb Therapy is
    `"Barb@gmail.com"`
    'ActiveWorkbook.Worksheets("Felisa, Robin V.").Select   Email for Felisa, Robin V. is
    `"Robin@yahoo.com"`    

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

    strNames(1) = "ABC@gmail.com"
    strNames(2) = "Achieve@gmail.com"
    strNames(3) = "Barb@gmail.com"
    strNames(4) = "Robin@yahoo.com"

    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

Solution

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 
`"ABC@gmail.com"`
'ActiveWorkbook.Worksheets("Achieve Therapy").Select    Email for Achieve Therapy is 
`"Achieve@gmail.com"`
'ActiveWorkbook.Worksheets("Barb Therapy").Select       Email for Barb Therapy is 
`"Barb@gmail.com"`
'ActiveWorkbook.Worksheets("Felisa, Robin V.").Select   Email for Felisa, Robin V. is 
`"Robin@yahoo.com"`


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

strNames(1) = "ABC@gmail.com"
strNames(2) = "Achieve@gmail.com"
strNames(3) = "Barb@gmail.com"
strNames(4) = "Robin@yahoo.com"




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