Trying to get vba nested for loop to work for email and pdf export

user_18431517 0
Viewed 68

This code is supposed to do the following:

  1. Take the four worksheets listed in the array (dim as s) export them 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.

I have this code working correctly except for Step 3.

The problem I am having is getting the 4 email addresses to loop correctly to load them into the “To: field” for the emails. It will assign the first email address to “strNames” but will continue to use it until after all 4 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 4 email addresses and 4 worksheets, I end up with 16 emails when it should be 4 different emails each having 4 different applicable attachments.

I need a nested loop in the code to cycle through the email list, but I’ve been unable to make it work as desired. I added a few notes below to illustrate what is needed.

Just to clarify, when done I should have 4 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

I would appreciate any help with this VBA code.

Thanks, Ted

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
outlook vba excel pdf loops
2 Answers

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
user_81169260

I've ran into file lock issues deleting PDFs before. Instead of deleting the PDFs, I would save them to a folder in the Environ("Temp") directory.

Sub PDF_to_Email_2022_03_07()
    Const Subject As String = "EI Payment Report"
    Const Body As String = "Enclosed is your monthly Report."
    Dim SheetNames As Variant
    SheetNames = Array("ABC Therapy", "Achieve Therapy", "Barb Therapy", "Felisa, Robin V.")
    
    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 = 0 To 3
        GetPDFEmail ws:=Worksheets(SheetNames(i)), ToAddress:=strNames(i), Subject:=Subject, Body:=Body
    Next i

End Sub

Function GetPDFEmail(ws As Worksheet, Optional ToAddress As String, Optional CC As String, Optional BCC As String, Optional Subject As String, Optional Body As String, Optional Display As Boolean = True)
    Dim FileName As String
    FileName = PDFFileName(ActiveWorkbook, ws)
    ws.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName
    
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    With OutlookMail
        .To = ToAddress
        .CC = CC
        .BCC = BCC
        .Subject = "EI Payment Report"
        .Body = "Enclosed is your monthly Report."
        .Attachments.Add FileName
        .Display
    End With
    Kill FileName
End Function

Function PDFFileName(wb As Workbook, ws As Worksheet) As String
    Dim xIndex As Long
    xIndex = VBA.InStrRev(wb.FullName, ".")
    PDFFileName = VBA.Left(wb.FullName, xIndex - 24) & "_" + ws.Name & ".pdf"
End Function
user_99127140
Related