Send Emails using Excel VBA from a table

Question

I have a list of emails that are in a table and I would like to send these people emails.

At the moment, my code only references one cell where I have stored multiple emails.

emailItem.To = Range("A2").Value
emailItem.CC = Range("B2").Value

How do I reference a table array so when I add or remove someone from the distribution list, it becomes 'dynamic'.

Here is what my table looks like:

Here is the code I'm working with:

Option Explicit

Sub Send_Email_With_Attachment()    
    Dim emailApplication As Object
    Dim emailItem As Object

    Set emailApplication = CreateObject("Outlook.Application")
    Set emailItem = emailApplication.CreateItem(0)

    'Date Update in Subject Line

    Dim lastSunday As Date
    lastSunday = DateAdd("d", 1 - Weekday(Now), Now)

    'Now build the email.    
    emailItem.To = Range("A2").Value    
    emailItem.CC = Range("B2").Value    

    emailItem.Subject = "Training Report  - " & Format(lastSunday, "dd-MM-yyyy")    
    emailItem.Body = "Dear All" & vbCrLf & vbCrLf & "Please find attached the Weekly  Training report." & vbCrLf & vbCrLf & "Kind Regards,"

    ' Attach any file from computer


    'Send the email
    emailItem.Display 
End Sub

Answer 1

Instead of

emailItem.To = Range("A2").Value    
emailItem.CC = Range("B2").Value    

use

Dim EmailTable As ListObject  ' define your email table in the sheet
Set EmailTable = ThisWorkbook.Worksheets("Sheet1").ListObjects("Email2")

emailItem.To = Join(Application.Transpose(EmailTable.ListColumns("To").DataBodyRange.Value2), ";")    
emailItem.CC = Join(Application.Transpose(EmailTable.ListColumns("CC").DataBodyRange.Value2), ";")    

Note that Email2 is the name of your table and Sheet1 needs to be the name of the worksheet. Transpose will make a one dimensional array out of the column that we can Join into a string seperated by ;

Answer 2

This is code I used to generate emails.

The code will only work if BOTH 'To & CC' are in the same Table.

The code will work only on the ACTIVE Sheet that you're in.

The code also references a PAST date and can be modified very easily. Change this part of the code: "("d", 1 - Weekday(Now), Now)" to suit your need.

Option Explicit

Sub Send_Email_With_Attachment() Dim OutApp As Object, OutMail As Object Dim emailTo As String, emailCC As String Dim lastSunday As Date Dim c As Range

lastSunday = DateAdd("d", 1 - Weekday(Now), Now)

emailTo = WorksheetFunction.TextJoin(";", True, ActiveSheet.Range("Email2[To]"))
emailCC = WorksheetFunction.TextJoin(";", True, ActiveSheet.Range("Email2[CC]"))
 
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = emailTo
        .CC = emailCC
        .Subject = "Report  - " & Format(lastSunday, "dd-MM-yyyy")
        .Body = "Dear All" & vbCrLf & vbCrLf & _
        "Please find attached the Weekly report." & vbCrLf & vbCrLf & "Kind Regards,"
        '.Attachments.Add ""
        .Send
    End With

End Sub