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
Some suggestions:
contactsHeaderRange
instead of xRG
)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