Creating a single email from list

[Rkiser42]

Hey y’all,

I am having issues finding a VBA that can create an email in outlook from a list of email addresses. The email addresses change fairly constantly and will sometimes have blank cells in between them. I would like it to create a single email but can only find VBAs that create individual email to each address rather than compiling all in one email.
Any help would be fantastic as it would smooth out our processes here at work.

 

[welshgasman]

Concatenate all the email addresses with a ';'
So just walk therough the range for any non empty cells.?

Here is something I used, before moving to Access

' First set the filter to get just the rows we want
With ActiveSheet
    .AutoFilterMode = False
    .Range("A1:" & strLastCell).AutoFilter
    Selection.AutoFilter Field:=8, Criteria1:="Yes"
End With

then

For Each rngCell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
   .... your code to concatenate here
Next rngCell

HTH

 

[Rkiser42]

Concatenate all the email addresses with a ';'
So just walk therough the range for any non empty cells.?

Here is something I used, before moving to Access

' First set the filter to get just the rows we want
With ActiveSheet
    .AutoFilterMode = False
    .Range("A1:" & strLastCell).AutoFilter
    Selection.AutoFilter Field:=8, Criteria1:="Yes"
End With

then

For Each rngCell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
   .... your code to concatenate here
Next rngCell

HTH

So here’s the code I currently have that keeps creating emails to individual addresses. Where would I input your code?


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

 

[welshgasman]

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)
    ' Create your email list here'
    For Each xRgEach In xRg
        xRgVal = xRgEach.Value & ";"
    Next
    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

Set xMailOut = Nothing
Set xOutApp = Nothing
Application.ScreenUpdating = True
End Sub

Might want to add a test for empty cells. I knew all mine would be populated.

 

[Rkiser42]

So I tried the posted lines of coding and it only opened the last cell specified in the dialog box. I wish I could be more helpful, but I am new to all of this.

 

[Rkiser42]

This is basically what I am working with. I need the VBA to create a single email with all these addressees in one column. The addresses change out pretty constantly. Its a contractor business so I get different accounts routinely. Maybe this helps?

 

[welshgasman]

No, it's my fault.
We need to add each cell, and the code was 'replacing' with next cell, which is what you originally wanted as you were sending an email to each recipient.
The code blocks remove any formatting but change this line
xRgVal = xRgEach.Value & ";" to xRgVal = xRgVal & xRgEach.Value & ";"

You will need to either check for empty cell or filter them out first.

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)
    ' Create your email list here'
    For Each xRgEach In xRg
        xRgVal =  xRgVal & xRgEach.Value & ";"
    Next
    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

Set xMailOut = Nothing
Set xOutApp = Nothing
Application.ScreenUpdating = True
End Sub

 

[Rkiser42]

It worked! You sir are the greatest!