Copying multiple emails from cells to "To:" (or CC/BCC) in Outlook

[HappyChappy1558]

Hello,

I have one Workbook with two Sheets, lets say Sheet1 and Sheet2. Sheet1 has a list of people I need to email which it changes every week. Sheet2 is an Alpha Roaster with everyone's name, SSN, and email (personal and official).

My tool saves the SSN's in Sheet1 to a dictionary and then uses that to find its match on the alpha roster in Sheet2. When it does, it copies the corresponding personal and official emails and pastes them back on Sheet1. At this point Sheet1 has all the emails of the people I need to email. Personal emails in column C and official emails in column D. My tool currently opens a new outlook email for every email in column D, but I need it to have every email address in just one email.

So again, what I am looking for is a way to match the SSN's in Sheet1 with the SSN's in Sheet2 and then pull the email address for the matches in Sheet2 and have them all added to the same outlook email in the "To:" section.

Below is my current code which does everything except it adds each email address to a new email. Below that, you can copy and paste my code.

Sub Copy_Send()
Dim Cl As Range
Dim Dic As Object
Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long


Set Dic = CreateObject("scripting.dictionary")

'This part copies Personal emails in cell AM on Alpha Roster
With Sheets("Sheet2")
For Each Cl In .Range("A2", .Range("B" & Rows.Count).End(xlUp))
Dic(Cl.Value) = Cl.Offset(, 1).Value
Next Cl
End With
With Sheets("Sheet1") 'Cell A2 is where the SSN's will be on the report you wnat to match with the aplha roster
For Each Cl In .Range("A2", .Range("B" & Rows.Count).End(xlUp))
If Dic.exists(Cl.Value) Then Cl.Offset(, 1).Value = Dic(Cl.Value)
Next Cl

End With

'This part copies military emails in cell AN on Alpha Roster
With Sheets("Sheet2")
For Each Cl In .Range("A2", .Range("B" & Rows.Count).End(xlUp))
Dic(Cl.Value) = Cl.Offset(, 2).Value
Next Cl
End With
With Sheets("Sheet1")
For Each Cl In .Range("B2", .Range("B" & Rows.Count).End(xlUp))
If Dic.exists(Cl.Value) Then Cl.Offset(, 2).Value = Dic(Cl.Value)
Next Cl
End With

'Email portion below
lr = Cells(Rows.Count, "D").End(xlUp).Row
Set Mail_Object = CreateObject("Outlook.Application")

For i = 2 To lr
With Mail_Object.CreateItem(o)


.Subject = "Test Code2" 'If you want the value in a excel cell to be the subject use .Subject = Range("B1").Value
.To = Range("C" & i)
.HTMLBody = "Good Morning Lt Robinson," & "<br>" & "<br>" & "I am sendig this email with a test program. Hopefully you get it."
.Display
End With
Next i

End Sub

 

[daverunt]

Hi,

It's not very clear to me whether you want one or 2 columns of addresses adding?
It looks as though from your code you are sending a new email to the column C address in each row though you mention there are addresses in column D and that is the row cycled through to create each mail?

You can concatenate a column of addresses in the following way, prior to generating the mail and where you can use EMailSendTo in the "To" filed of the email.
You can also concatenate in the column C addresses if required using cells(i & "C") or the or the offset to D as shown in the commented out code.

If using 2 columns of addresses and there's nothing in Column D and there is in Column C the Column C address won't be added because of - If Cells(i, "D").Value <> "" Then
Hope this gives you a pointer.

lr = Cells(Rows.Count, "D").End(xlUp).Row

SendList = ""
            For i = 1 To lr
                If Cells(i, "D").Value <> "" Then
                    SendList = SendList & Cells(i, "D").Value & "; "
                    'SendList = SendList & Cells(i, "D").Value & "; " & Cells(i, "D").Offset(0, -1).Value & "; " ' can add addresses in column C if required
                    EMailSendTo = SendList
                End If

Next i

Set Mail_Object = CreateObject("Outlook.Application")
With Mail_Object.CreateItem(o)
.Subject = "Test Code2" 'If you want the value in a excel cell to be the subject use .Subject = Range("B1").Value
.To = EMailSendTo
.HTMLBody = "Good Morning Lt Robinson," & "<br>" & "<br>" & "I am sendig this email with a test program. Hopefully you get it."
.Display
End With