Single email with multiple email addresses from selected cells

[Kevalson]

Hello all.
I found a code that will allow me to create the command button that will create multiple Outlook emails, 1 for each email in a different selected cell.

What I need it to do is instead of multiple single emails, it would create just 1 single email with the multiple email addresses from the selected cells.
The email addresses in the "To" would of course have to have the "; " to separate the email addresses.

I borrowed the code from
https://www.extendoffice.com/documents/excel/4717-excel-macro-send-email-to-address-in-cells.html

I suspect it is a small tweak, but I am still learning.

Any help would be appreciated.

Code below:

Sub SendEmailToAddressInCells()
Dim xRg As Range
Dim xRgEach As Range
Dim xRgVal As String
Dim xAddress As String
Dim xOutApp As Outlook.Application
Dim xMailOut As Outlook.MailItem
On Error Resume Next
xAddress = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select email address range", "KuTools For Excel", xAddress, , , , , 8)
If xRg Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set xOutApp = CreateObject("Outlook.Application")
Set xRg = xRg.SpecialCells(xlCellTypeConstants, xlTextValues)
For Each xRgEach In xRg
xRgVal = xRgEach.Value
If xRgVal Like "?*@?*.?*" Then
Set xMailOut = xOutApp.CreateItem(olMailItem)
With xMailOut
.To = xRgVal
.Subject = "Test"
.Body = "Dear " _
& vbNewLine & vbNewLine & _
"This is a test email " & _
"sending in Excel"
.Display
'.Send
End With
End If
Next
Set xMailOut = Nothing
Set xOutApp = Nothing
Application.ScreenUpdating = True
End Sub

 

[daverunt]

Instead of having a loop for each address in the range include the mail, concatenate the addresses in a loop then create the mail.

Sub SendEmailToAddressInCells()
 Dim xRg As Range
 Dim xRgEach As Range
 Dim xRgVal As String
 Dim xAddress As String
 Dim xOutApp As Outlook.Application
 Dim xMailOut As Outlook.MailItem
 On Error Resume Next
 xAddress = ActiveWindow.RangeSelection.Address
 Set xRg = Application.InputBox("Please select email address range", "KuTools For Excel", xAddress, , , , , 8)
 If xRg Is Nothing Then Exit Sub
 Application.ScreenUpdating = False
 Set xOutApp = CreateObject("Outlook.Application")
 Set xRg = xRg.SpecialCells(xlCellTypeConstants, xlTextValues)
 For Each xRgEach In xRg
 xRgVal = xRgEach.Value
 If xRgVal Like "?*@?*.?*" Then
 mailTo = mailTo & xRgVal & " ;"
 MsgBox (mailTo) -----------------I just include this to test. 
 End If
 Next
 Set xMailOut = xOutApp.CreateItem(olMailItem)
 With xMailOut
 .To = mailTo
 .Subject = "Test"
 .Body = "Dear " _
 & vbNewLine & vbNewLine & _
 "This is a test email " & _
 "sending in Excel"
 .Display
 '.Send
 End With
 
 Set xMailOut = Nothing
 Set xOutApp = Nothing
 Application.ScreenUpdating = True
 End Sub

 

[Kevalson]

Well there ya go.

Works.

Thank you very much.

 

[daverunt]

Glad to help.