VBA - Emailing string of email addresses

Jasesair

Board Regular
Joined
Apr 8, 2015
Messages
230
Office Version
  1. 2016
I'm attempting to create VBA to email (in the BCC field) a string of email addresses. Each email can be found in cells AT7:AT107

I'd also like to include the email signature into the VBA but have little idea how to do this.

VBA Code:
Sub EmailJuniors()

    Dim OutApp As Object
    Dim OutMail As Object

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
'        .To = Range("??")
'        .CC = Range("??")
        .BCC = Join(Application.Transpose(.Range("AT7:AT107").Value), ";") & ";"
        .Subject = Range("AP3")
        .Body = Range("AO2") & vbLf & _
                "" & vbLf & _
        .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
 

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.

Logit

Well-known Member
Joined
Aug 31, 2016
Messages
3,996
Code:
Sub SendEmail()

    Dim c As Range
    Dim OutLookApp As Object
    Dim OutLookMailItem As Object
    Dim i As Integer
    
    Dim xPath As String
    
    xPath = Application.ActiveWorkbook.Path
      
    With Sheets("Email")        '<-- change sheet name as required
        For Each c In Range("AT7:AT" & Cells(Rows.Count, "AT").End(xlUp).Row).Cells
        
            Set OutLookApp = CreateObject("Outlook.application")
            Set OutLookMailItem = OutLookApp.CreateItem(0)
            
            With OutLookMailItem
                    .To = c.Value
                    .CC = "Your CC here"
                    .BCC = "test"
                    .Subject = "Your Subject here"
                    .HTMLBody = "Your Body content here"
                    .Display
                    '.Send
            End With
            
        Next c
    End With

End Sub
 

Jasesair

Board Regular
Joined
Apr 8, 2015
Messages
230
Office Version
  1. 2016
This unfortunately created separate emails for each email address in the range. I'm really wanting the one email to be generated with all the the email address populating into the BCC field...and obviously separated with a semi-colon. At times, there will be double-ups of email addresses in the range. Ideally, this VBA would only populate unique email addresses from the range.
 

Jasesair

Board Regular
Joined
Apr 8, 2015
Messages
230
Office Version
  1. 2016

ADVERTISEMENT

Hi Kenneth, this is looking like exactly what I'm chasing. Unfortunately I'm getting Run-Time Error 438: Object doesn't support this property of method. It's highlighting your line. This is what I have so far:

VBA Code:
Sub EmailJuniors()

    Dim c As Range
    Dim OutLookApp As Object
    Dim OutLookMailItem As Object
    Dim i As Integer
    
    Dim xPath As String
    
    xPath = Application.ActiveWorkbook.Path
      
    With Sheets("2021")        '<-- change sheet name as required
        For Each c In Range("AT7:AT107" & Cells(Rows.Count, "AT").End(xlUp).Row).Cells
        
            Set OutLookApp = CreateObject("Outlook.application")
            Set OutLookMailItem = OutLookApp.CreateItem(0)
            
            With OutLookMailItem
                    .To = c.Value
                    .CC = "Your CC here"
                    .BCC = Join(WorksheetFunction.Transpose(WorksheetFunction.Unique(Range("AT7:AT107"), False)), ";")
                    .Subject = "Your Subject here"
                    .HTMLBody = "Your Body content here"
                    .Display
                    '.Send
            End With
            
        Next c
    End With

End Sub
 

Kenneth Hobson

Well-known Member
Joined
Feb 6, 2007
Messages
3,170
Office Version
  1. 365
Platform
  1. Windows
Unique() was probably not included until a later version of your Excel. My 365 has it. This function can easily have a run-time error too if one cell has an error.
If it had worked, you can easily test manually using =Unique(AT7:AT107) or as a MsgBox or in VBA's Immediate Window. e.g.
Excel Formula:
?Join(WorksheetFunction.Transpose(WorksheetFunction.Unique(Range("AT7:AT107"), False)), ";")
? in Immediate Window is like Debug.Print only more immediate...

It looks like you are now iterating the range which creates an email for each cell in the range.

A bit more involved solution I used to use in earlier versions of Excel made use of the dictionary object. Of course this method as-is will error too if there is an error cell.
VBA Code:
Sub Test_UniqueArrayByDict()
  Dim bcc As String
  bcc = Join(UniqueArrayByDict(WorksheetFunction.Transpose(Range("AT7:AT107"))), ";")
  MsgBox bcc
End Sub

' http://www.excelforum.com/excel-programming-vba-macros/819998-filter-and-sort-scripting-dictionary.html
'Early Binding method requires Reference: MicroSoft Scripting Runtime, scrrun.dll
Function UniqueArrayByDict(Array1d As Variant, Optional compareMethod As Integer = 0) As Variant
  Dim dic As Object 'Late Binding method - Requires no Reference
  Set dic = CreateObject("Scripting.Dictionary")  'Late or Early Binding method
  'Dim dic As Dictionary     'Early Binding method
  'Set dic = New Dictionary  'Early Binding Method
  Dim e As Variant
  dic.CompareMode = compareMethod
  'BinaryCompare=0
  'TextCompare=1
  'DatabaseCompare=2
  For Each e In Array1d
    If Not dic.Exists(e) Then dic.Add e, Nothing
  Next e
  UniqueArrayByDict = dic.Keys
End Function
 

Jasesair

Board Regular
Joined
Apr 8, 2015
Messages
230
Office Version
  1. 2016
Are you able to help me with this just to remove the Unique? Might be neater to just have a helper column in my worksheet.

VBA Code:
Join(WorksheetFunction.Transpose(WorksheetFunction.Unique(Range("AT7:AT107"), False)), ";")
 

Watch MrExcel Video

Forum statistics

Threads
1,129,299
Messages
5,635,391
Members
416,856
Latest member
silentir

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top