Help with VBA to send email to several recipients listed in different columsn

[mgrass1142]

I want to use VBA so that I can send the same email to all recipients within an excel row, and have it go through several rows. So if I have Column A, B and C with email recipients I want the recipients in A1, B1 and C1 to get one email referring to them, and A2, B2, C2 to get a different email (same body but changing the names). I am thinking the body of each email to be something like "Dear "A1", you've been assigned "B1" and "C1" to work with you", having A1's email address in the To" field and B1,C1 CC'd, and have the macros do that for all rows. Can anyone help me with this?

[Logit]

.
The goto resource for VBA Email : https://www.rondebruin.nl/win/s1/outlook/mail.htm

[mgrass1142]

Thanks Logit! The issue is that the code proposed there is one where You send a separate email to each of the recipients listed in one column (i.e one recipient per email). I need sub-groups of recipients, meaning for each row, all recipients listed across a row get the same email but its different from the email that others row get in that it names the people associated to the emails. Any idea how to adjust Rondebruins examples to that end?

[Logit]

.
You can list as many email addresses as you want in your project, separated by a comma (or is it a semi-colon?). Works just like Outlook when you want to send the same message to several different folks.

[Charlize]

A bit adapted version. A1 is the to and B1 and C1 are the cc parts.

Sub Test1()'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Working in Office 2000-2016
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range


Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")


On Error GoTo cleanup
For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.cc = cell.Offset(0, 1).Value & ";" & cell.Offset(0, 2).Value
.Subject = "Work Assignments"
'"Dear "A1", you've been assigned "B1" and "C1" to work with you"
.Body = "Dear " & Split(cell.Value, "@")(0) & ", you've been assigned " & vbCrLf & _
Split(cell.Offset(0, 1).Value, "@")(0) & " and " & _
Split(cell.Offset(0, 2).Value, "@")(0) & vbCrLf & _
" to work with you."
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
'.Send 'Or use Display
.display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell


cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Charlize