Outlook/Excel VBA : Send email to two recipients, ignore second recipient if cell value is blank or error

Hi,

I have an excel sheet with two columns, Column A has primary email ID and Column B has the secondary email ID, most of the cells in column A has the corresponding cells in Column B populated, but some are blank.

My requirement is to send the same email to the email address from cells in column A and Column B, but ignore the recipient from column B if column B is blank or has an error value,

Email.JPG
Thanks in Advance

VB
V BSenior AnalystAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

[ fanpages ]IT Services ConsultantCommented:
"My requirement is to send the same email to the email address..."

What is the content of the e-mail you are sending?
Is it the same for every row (both a Primary & an optional Secondary e-mail), different for each, the same for all Primary e-mails, the same for all Secondary e-mails, or the same for every recipient?
V BSenior AnalystAuthor Commented:
Hi,

Content is the same for both primary and secondary email ID's,

for e.g an alert can be emailed to primary and secondary email ID stating that the report has been refreshed.

hope this helps

VB
Rgonzo1971Commented:
Hi,

pls try

Sub MailToDestination()
    Dim SendTo As String
    Dim ToMSg As String
    Dim ToSubject As String
 
    For Each c In Range(Range("A1"), Range("A" & Cells.Rows.Count).End(xlUp))
        SendTo = c
        If Not (IsError(c.Offset(0, 1))) Then
            If c.Offset(0, 1) <> "" Then SendTo = SendTo & "; " & c.Offset(0, 1)
        End If
        If SendTo <> “” Then
            ToSubject = c.Offset(0, 2)
            ToMSg = c.Offset(0, 3)
            Send_Mail SendTo, ToSubject, ToMSg
        End If
    Next
End Sub
Sub Send_Mail(SendTo As String, ToSubject, ToMSg As String)
    Dim OutlookApp As Object
    Dim OutlookMail As Object
 
    Set OutlookApp = CreateObject(“Outlook.Application”)
    Set OutlookMail = OutlookApp.CreateItem(0)
 
    With OutlookMail
        .to = SendTo
        .CC = ""
        .BCC = ""
        .Subject = ToSubject
        .Body = ToMSg
        .Display  ' or just put .Send to directly send the mail instead of display
    End With
 
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub

Open in new window

Regards
Starting with Angular 5

Learn the essential features and functions of the popular JavaScript framework for building mobile, desktop and web applications.

V BSenior AnalystAuthor Commented:
Hi Rgonzo1971,

That was really fast !!!!! :)

will try this one out and let you know.

thanks for your help
VB
[ fanpages ]IT Services ConsultantCommented:
Content is the same for both primary and secondary email ID's,

for e.g an alert can be emailed to primary and secondary email ID stating that the report has been refreshed.

hope this helps

Yes, thank you.

It means every recipient can be added as a Blind Closed Copy address, & only one e-mail need ever be created when the process is executed.

The suggestion provided already creates multiple e-mails; one for every recipient or, in the case of a Primary & a Secondary e-mail address on one row; one e-mail for both of those addresses.

So, you could either send, say, 500 individual e-mail messages each with a single recipient, or one e-mail sent to 500 recipients.
Rgonzo1971Commented:
Corrected code
Sub MailToDestination()
    Dim SendTo As String
    Dim ToMSg As String
    Dim ToSubject As String
 
    For Each c In Range(Range("A1"), Range("A" & Cells.Rows.Count).End(xlUp))
        SendTo = c
        If Not (IsError(c.Offset(0, 1))) Then
            If c.Offset(0, 1) <> "" Then SendTo = SendTo & "; " & c.Offset(0, 1)
        End If
        If SendTo <> "" Then
            ToSubject = c.Offset(0, 2)
            ToMSg = c.Offset(0, 3)
            Send_Mail SendTo, ToSubject, ToMSg
        End If
    Next
End Sub
Sub Send_Mail(SendTo As String, ToSubject As String, ToMSg As String)
    Dim OutlookApp As Object
    Dim OutlookMail As Object
 
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
 
    With OutlookMail
        .to = SendTo
        .CC = ""
        .BCC = ""
        .Subject = ToSubject
        .Body = ToMSg
        .Display  ' or just put .Send to directly send the mail instead of display
    End With
 
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
V BSenior AnalystAuthor Commented:
Hi Rgonzo1971,

i see you have added a corrected code, i am sorry but it looks like the same code you posted before, has anything changed ?

hi fanpages,

thanks for you feedback :)

vb
Rgonzo1971Commented:
Some of the "" were not right
V BSenior AnalystAuthor Commented:
Thanks Rgonzo1971,

i will test this one out and update you

VB
V BSenior AnalystAuthor Commented:
hi Rgonzo1971,

your code worked like magic, much appreciated.

thanks
VB
Thomas Zucker-ScharffSolution GuideCommented:
Vineeth,

When you tried the code were you prompted to allow the sending from outlook?  This is a security measure but you can bypass it by using the following code (use it where the current line is starting with the .display command):
    .display
    Application.Wait (Now + TimeValue("0:00:02"))
    Application.SendKeys "%s"
    ' Next line is commented out, but can be used if ClickYes is installed
    '.Send
    End With
    Set OutMail = Nothing

Open in new window

It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.