VBA - Emailing string of email addresses

[Jasesair]

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.

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

 

[Logit]

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]

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.

 

[Kenneth Hobson]

1. Unique:

.bcc=
Join(WorksheetFunction.Transpose(WorksheetFunction.Unique(Range("AT7:AT107"), False)), ";")

2. Signature, Ron de Bruin, Insert Outlook Signature in mail

 

[Jasesair]

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:

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]

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.

?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.

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]

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.

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