This code is supposed to do the following:
- Take the four worksheets listed in the array (dim as s) export them 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.
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 [email protected] Only after it exits that loop, will it cycle down to the next email address [email protected] 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 “[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
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
`"[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
CodePudding user response:
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
CodePudding user response:
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) = "[email protected]"
strNames(2) = "[email protected]"
strNames(3) = "[email protected]"
strNames(4) = "[email protected]"
Dim i As Long
For i = 1 To 4
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