How to send email to multiple recipients with drop down list?

Question

I am trying to send one email to group of people in .CC.

I have one Excel worksheet called "Project" with drop down list which contains contact group names.

Workers 1 shift (address B2), on the other worksheet called "contacts" I have email list in columns with first row of name of above groups (headline address A2:AX2).

I want to choose from the drop down list the email group and send one email to each person on the list. Now I have an Inputbox with range that I have to select manually.

Sub EmailCC()

    Dim xOTApp As Object
    Dim xMItem As Object
    Dim xCell As Range
    Dim xRg As Range
    Dim xEmailAddr As String
    Dim xTxt As String

    On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("Address list:", "Range", xTxt, , , , , 8)

    If xRg Is Nothing Then Exit Sub
    Set xOTApp = CreateObject("Outlook.Application")

    For Each xCell In xRg
        If xCell.Value Like "*@*" Then
            If xEmailAddr = "" Then
                xEmailAddr = xCell.Value
            Else
                xEmailAddr = xEmailAddr & ";" & xCell.Value
            End If
        End If
    Next

    Set xMItem = xOTApp.CreateItem(0)

    With xMItem
        .To = " "
        .CC = xEmailAddr
        .Display
    End With

End Sub

Excel file with macro example

Answer 1

Some suggestions:

• Don't use On Error Resume Next unless it's strictly necessary
• Name your variables to something meaningful (use contactsHeaderRange instead of xRG)
• Comment your code
• Split the code in steps

Read Code's comments and adjust it to fit your needs

EDIT: Changed from one email per address, to all address in one email

Public Sub SendEmailsByGroup()
    
    Dim projectSheet As Worksheet
    Set projectSheet = ThisWorkbook.Worksheets("Project")
    
    Dim groupCell As Range
    Set groupCell = projectSheet.Range("B2")
    
    Dim groupName As String
    groupName = groupCell.Value
    
    Dim contactsSheet As Worksheet
    Set contactsSheet = ThisWorkbook.Worksheets("Contacts")
    
    Dim contactsHeadersRange As Range
    Set contactsHeadersRange = contactsSheet.Range("A2:C2")
    
    ' Get header according to group name
    Dim contactsGroupHeader As Range
    Set contactsGroupHeader = contactsHeadersRange.Find(groupName)
    
    ' If the group is not found, cancel the process
    If contactsGroupHeader Is Nothing Then
        MsgBox "Group name not selected or found"
        Exit Sub
    End If
    
    ' Get group email values from range (use transpose to pass the range to a 1D array)
    Dim groupEmails As Variant
    groupEmails = Application.Transpose(contactsSheet.Range(contactsGroupHeader.Offset(1, 0), contactsSheet.Cells(contactsSheet.Rows.Count, contactsGroupHeader.Column).End(xlUp)).Value)
    
    SendEmails groupEmails
    

End Sub

Private Sub SendEmails(ByVal groupEmails As Variant)

    Dim outlookApp As Object
    Set outlookApp = CreateObject("Outlook.Application")
    
    Dim mailItem As Object
    Set mailItem = outlookApp.CreateItem(0)
    
    Dim emailsList As String
    emailsList = Join(groupEmails, ";")
    
    With mailItem
        '.To =
        .CC = emailsList
        .Display
    End With
    
    
End Sub

Let me know if it works

Answer 2

Hello try this: put a drop-down list on Project sheet. Like this: drop down list in Excel

and the code:

Option Explicit
Sub EmailCC()
    Dim xOTApp As Object
    Dim xMItem As Object
    Dim xCell As Range
    Dim xRg As Range
    Dim xEmailAddr As String
    Dim xTxt As String
    Dim w As Workbook
    Dim sProject As Worksheet
    Dim sContacts As Worksheet
    Dim i As Integer
    Dim column  As Integer
    Set w = ActiveWorkbook
    Set sProject = w.Sheets(1)
    Set sContacts = w.Sheets(2)
    On Error Resume Next
    column = sProject.Cells(3, 9).Value
    If Not (IsNumeric(column)) Then Exit Sub
    Set xOTApp = CreateObject("Outlook.Application")
    i = 3
    Do While Not sContacts.Cells(i, column).Value = ""
                xEmailAddr = sContacts.Cells(i, column).Value & ";" & xEmailAddr
                i = i + 1
    Loop
    Set xMItem = xOTApp.CreateItem(0)
    With xMItem
        .To = " "
        .CC = xEmailAddr
        .Display
    End With
End Sub

Excel file