PDA

View Full Version : VBA Outlook single mail instead of multiple mails to recipient



Maxicus
07-09-2018, 01:28 AM
Hi

I have the following code, which works but would like to improve.

the purpose of the code is to send a report to multiple recipients at once, these recipients mail addresses are found on Sheet1 Column H. they are also dynamic.

the code works fine in the sense that it opens and creates the attachment for each recipient, but it creates a new mail for each recipient. I would only like to change it so that it creates a single new mail and then places all the recipients into one e-mail.


Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")

On Error GoTo cleanup
For Each cell In Sheet1.Columns("H").Cells.SpecialCells(xlCellTypeConstants)

If cell.Value Like "?*@?*.?*" Then

Set OutMail = OutApp.CreateItem(0)

On Error Resume Next

With OutMail
.To = cell.Value
.Subject = "Reminder"
.Body = "Dear "
.Attachments.Add Sheet1.Range("B4") & "\3. SHE Reports\" & Sheet1.Range("AP4") & " " & Sheet1.Range("AO4") & " SHE REPORT" & ".pdf"
.Display
End With
On Error GoTo 0
Set OutMail = Nothing

End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True

mancubus
07-09-2018, 04:35 AM
assumptions:
1 recipients' email addresses are in a contiguous range in column H, starting at H1 (ie, there is no header cell)
2) Outlook separator is semicolon ";"



Sub vbax_63139_multi_recipient_email()

With CreateObject("Outlook.Application")
With .CreateItem(olMailItem)
.To = Join(Application.Transpose(Range("H1").CurrentRegion), ";")
.Subject = "Reminder"
.Body = "Dear "
.Attachments.Add Sheet1.Range("B4") & "\3. SHE Reports\" & Sheet1.Range("AP4") & " " & Sheet1.Range("AO4") & " SHE REPORT" & ".pdf"
.Display
End With
End With

End Sub