VBA Excel to Outlook, create one email to list of email addresses

[ericaindallas]

My goal is to create a macro in Excel to produce an email in Outlook to all the email addresses listed in column I in one email in the "To:" field.

What I've accomplished in the following VBA is that it creates a separate email for each email address listed in column I.

How do I create just one email for the list of email addresses in column I?

Typing in the email addresses within the VBA is not an option. The list of email addresses change with another macro.

Thank you in advance.

-Erica


Sub SendEmail()

Dim OutlookApp As Outlook.Application
Dim MItem As Outlook.MailItem
Dim cell As Range
Dim Subj As String
Dim EmailAddr As String
Dim Recipient As String
Dim Msg As String

'Create Outlook object
Set OutlookApp = New Outlook.Application

'Loop through the rows
For Each cell In Columns("I").Cells.SpecialCells(xlCellTypeVisible)
If cell.Value Like "*@*" Then

'Get the data
Subj = "This is the Subject Field"
Recipient = cell.Offset(0, -1).Value
EmailAddr = cell.Value

'Compose Message
Msg = Recipient & vbCrLf
Msg = Msg & "Please review the following message."

'Create Mail Item and view before sending
Set MItem = OutlookApp.CreateItem(olMailItem)
With MItem
.To = EmailAddr
.Subject = Subj
.Body = Msg
.Display
End With
End If
Next

End Sub

 

[Warship]

Something like?...

Sub SendEmail()

    Dim OutlookApp As Outlook.Application
    Dim MItem As Outlook.MailItem
    Dim cell As Range
    Dim Subj As String
    Dim EmailAddr As String
    Dim Recipient As String
    Dim Msg As String
    
    'Create Outlook object
    Set OutlookApp = New Outlook.Application
    
    'Loop through the rows
    For Each cell In Columns("I").Cells.SpecialCells(xlCellTypeVisible)
        If cell.Value Like "*@*" Then
            EmailAddr = EmailAddr & ";" & cell.Value
        End If
    Next
    
    Msg = "Please review the following message."
    Subj = "This is the Subject Field"
    
    'Create Mail Item and view before sending
    Set MItem = OutlookApp.CreateItem(olMailItem)
    With MItem
        .To = EmailAddr
        .Subject = Subj
        .Body = Msg
        .Display
    End With

End Sub

 

[ericaindallas]

Warship, this works perfectly! Thank you!

Perhaps you can help me with another part...

I would like to put all the email addresses in column L in the CC: field.

How would I go by including that in my VBA?

For Each cell In Columns("L").Cells.SpecialCells(xlCellTypeVisible)
If cell.Value Like "*@*" Then
CC: EmailAddr = CC: EmailAddr & ";" & cell.Value

Thanks,
Erica

 

[ericaindallas]

Nevermind Warship, I figured it out.

Thank you very much for your help!!

-Erica

And here is the final VBA I've ended up with just to share the end results.


Sub SendEmail()

Dim OutlookApp As Outlook.Application
Dim MItem As Outlook.MailItem
Dim cell As Range
Dim Subj As String
Dim EmailAddr As String
Dim Recipient As String
Dim Msg As String

'Create Outlook object
Set OutlookApp = New Outlook.Application

'Loop through the rows
For Each cell In Columns("I").Cells.SpecialCells(xlCellTypeVisible)
If cell.Value Like "*@*" Then
EmailAddr1 = EmailAddr1 & ";" & cell.Value
End If
Next

For Each cell In Columns("L").Cells.SpecialCells(xlCellTypeVisible)
If cell.Value Like "*@*" Then
EmailAddr2 = EmailAddr2 & ";" & cell.Value
End If
Next

Msg = Msg & "Please review the following lead." & vbCrLf
Subj = "LEAD REFERRAL-" & Range("E19") & "-" & Range("I21") & "-" & Range("I23")


'Create Mail Item and view before sending
Set MItem = OutlookApp.CreateItem(olMailItem)
With MItem
.To = EmailAddr1
.CC = EmailAddr2
.Subject = Subj
.Body = Msg & vbCrLf
.Display
End With

End Sub

 

[Warship]

That looks good, however you haven't updated your Dim's.

Also note that: Like "*@*" will allow email@yahoo to be on the list.

Maybe: Like "*@*.*" would be better although that would allow email@yahoo.comm

I usually use:

If cell.Value Like "*@*.??" OR cell.Value Like "*@*.???" Then

Probably depends on how much you "trust" your list.

 

[bradpeh]

sorry to bring up this old thread but i was wondering if this vba code could be used in excel 2003? cause i seem to have an error running this vba code in my excel 2003.

thanks
brad

 

[Jenelia]

sorry to bring up this old thread but i was wondering if this vba code could be used in excel 2003? cause i seem to have an error running this vba code in my excel 2003.

thanks
brad

Sorry to dig up an old thread but I recently used it to solve one of my own coding issues so I figured I'd contribute to the question, as I also was getting an error or two until I figured out the problem.

If you're getting an error, make sure you reference the outlook object library in the references area in the the visual basic editor. With the vb editor open select tools and references. This list is a rather large display of libraries you can check.

 

[dralliwd]

I have an additional question. How do you get the from email to be a group value instead of the users email when trying to send an email from excel.

 

[JFlash]

thanks to the folks that previously provided input on this thread. I just wanted to let you all know that i successfully used some of the above content to make macro in excel that pulls all the list of emails in the to line of an 2013 outlook email message. see below for the vba code i used. One though though, after this was all setup, i realized that since i took out the subject line, message body, and cc field population...a fairly quick manual work around is to just copy and paste the entire column of email addresses into a new email. when you click on the check names buttons it adds the semi colons and such and you're all set.


Sub exporttoemail()
Dim OutlookApp As Object
Dim MItem As Object
Dim cell As Range
Dim Subj As String
Dim EmailAddr As String
Dim Recipient As String
Dim Msg As String

'Create Outlook object
Set OutlookApp = CreateObject("Outlook.Application")

'Loop through the rows
For Each cell In Columns("F").Cells.SpecialCells(xlCellTypeVisible)
If cell.Value Like "*@*" Then
EmailAddr = EmailAddr & ";" & cell.Value
End If
Next
'Create Mail Item and view before sending
Set MItem = OutlookApp.CreateItem(olMailItem)
With MItem
.To = EmailAddr
.Display
End With

End Sub

Another note: I also ran into th same object library error and had a hard time figuring out how to get the references window to open as it was grayed out. Eventually the tools > references menu became available but i'm honestly not sure why it wasn't in the first place. maybe i had to save the file first. once i opened i confirmed the Microsoft Excel 15.0 Object Lirary refeverence was check.

thanks again or your help!