Excel to automate email in Outlook using specific fields in the excel sheet

Question

I'm working towards improving my efficiency at my workplace. For this there is a task of sending an e-mail to a list of people.

For this I have created the following code. Would like to know if this can be improved? This code takes the information from sheet "Final_list" in a workbook and headers are in row 1.

Sub EmailToAll()

    Dim outlookApp As Outlook.Application
    Dim outlookMail As Outlook.MailItem

    Set outlookApp = CreateObject("Outlook.Application")
    Set outlookMail = outlookApp.CreateItem(olMailItem)



    Dim sh As Worksheet
    Dim RowCount As Integer

    Worksheets("Final_List").Activate

    RowCount = 2

    Set sh = ActiveSheet

    Do While IsEmpty(sh.Cells(RowCount, 1).Value) = False

        Set outlookApp = CreateObject("Outlook.Application")
        Set outlookMail = outlookApp.CreateItem(olMailItem)
        With outlookMail
                'MsgBox sh.Cells(RowCount, 7).Value
                .To = sh.Cells(RowCount, 7).Value
                .CC = sh.Cells(RowCount, 9).Value
                .BCC = Empty
                .Subject = "[Update]" & " " & sh.Cells(RowCount, 1).Value & "-" & sh.Cells(RowCount, 8).Value
                .BodyFormat = 2
                .HTMLBody = "Hello "
                '.Display
                '.Save
                '.Close
                .Send
                'MsgBox "Mail saved for" & sh.Cells(RowCount, 7).Value & "!"
                RowCount = RowCount + 1
        End With

    Loop

    Set outlookMail = Nothing
    Set outlookApp = Nothing
    MsgBox "All mails sent!"

End Sub

score 0 · Answer 1 · answered Mar 01 '17 at 14:11

Not sure exactly what parts of this you would like to optimise but after looking at your example, here are a couple of things which I would look at changing;

The only things which are changing within the loop are the recipients and the subject line, the body is always the same (obviously I don't know what is stored in those cells) but maybe you could just construct the recipients string within the loop which should work fine if you separate the email addresses with semi-colons and send one email instead of multiple emails?

The other thing which I would mention is that you are stopping when you encounter a blank line which means that the loop may not pick up all recipients if someone deleted that line by mistake. There are many much more robust ways of locating the end of the data you could use.

Hope that helps.

0m3r · Accepted Answer · 2017-05-16T08:19:29.897

You do not need to create Outlook Object twice . Set outlookApp = CreateObject("Outlook.Application") and change Dim RowCount As Integer to Dim RowCount As Long

Also avoid .Activate

Option Explicit
Sub EmailToAll()
    Dim outlookApp As Outlook.Application
    Dim outlookMail As Outlook.MailItem
    Dim RowCount As Long

    Set outlookApp = CreateObject("Outlook.Application")

    RowCount = 2

    With Worksheets("Final_List")
        Do While IsEmpty(Cells(RowCount, 1).Value) = False

            Set outlookMail = outlookApp.CreateItem(olMailItem)
            With outlookMail
                    .To = Cells(RowCount, 7).Value
                    .CC = Cells(RowCount, 9).Value
                    .BCC = Empty
                    .Subject = "[Update]" & " " & Cells(RowCount, 1).Value & "-" & Cells(RowCount, 8).Value
                    .BodyFormat = 2
                    .HTMLBody = "Hello "
                    .Send
            End With
            RowCount = RowCount + 1
        Loop
    End With

    Set outlookMail = Nothing
    Set outlookApp = Nothing

    MsgBox "All mails sent!"

End Sub

Excel to automate email in Outlook using specific fields in the excel sheet

2 Answers2