I have a list of email addresses in excel that i need to send emails to. The subject and body are in cells besides the email address

Question

As mentioned in the subject of this post, I am attempting to send emails automatically by running a macro so that if cell J2 has the words "Send Reminder" in it, then the email address in cell K2 should be sent an email with the subject title in cell L2 and Body in Cell M. I have a list of emails ranging from cells K2:K59

Currently I have the following code:

    Sub SendEm()

Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long
lr = Cells(Rows.Count, "K").End(xlUp).Row
Set Mail_Object = CreateObject("Outlook.Application")
For i = 2 To lr
    With Mail_Object.CreateItem(o)
        .Subject = Range("L2").Value
        .To = Range("K" & i).Value
        .Body = Range("M2").Value
        .Send
    End With
Next i
    MsgBox "E-mail successfully sent", 64
    Application.DisplayAlerts = False
Set Mail_Object = Nothing
End Sub

I already have outlook open with references for Microsoft Outlook 14.0 Object Library selected amongst others, and I get an error saying " Run-time error '287' Application-definer or object-defined error, if i try to debug it, it highlights .Send in my code.

Can anyone help point out what I am doing wrong? I have tried various types of code to send emails based on different youtube videos etc. but seem to run into this error each time!

Thanks for your help ahead of time!

Edit1: I updated the code to the following based on suggestions and now a different issue:

Private Sub CommandButton21_Click()
'~~> Excel Objects/Variables
Dim ws As Worksheet
Dim lRow As Long, i As Long

'~~> Outlook Objects/Variables
Dim OutApp As Object
Dim OutMail As Object
Dim emailRange As Range, cl As Range
Dim sTo As String
Dim subjectRange As Range, c2 As Range
Dim sSubject As String
Dim bodyRange As Range, c3 As Range
Dim sBody As String


'~~> Set your worksheet here
Set ws = ThisWorkbook.Sheets("Sheet11")
'~~> Open Outlook
Set OutApp = CreateObject("Outlook.Application")

With ws

'~~> Get last row from Col J as that is what we
    '~~> are going to check for the condition
    lRow = .Range("J" & .Rows.Count).End(xlUp).Row

 '~~> Loop through the rows
    For i = 2 To lRow
        If .Range("J" & i).Value = "Send Reminder" Then
            '~~> Create new email

Set emailRange = Worksheets("Sheet11").Range("K2:K59")

         For Each cl In emailRange

         sTo = sTo & ";" & cl.Value
         Next
         sTo = Mid(sTo, 2)

Set subjectRange = Worksheets("Sheet11").Range("L2:L59")
          For Each c2 In subjectRange

          sSubject = sSubject & ";" & c2.Value
          Next
          sSubject = Mid(sSubject, 2)

Set bodyRange = Worksheets("Sheet11").Range("M2:M59")

        For Each c3 In bodyRange
        sBody = sBody & ":" & c3.Value
        Next
        sBody = Mid(sBody, 2)

            Set OutMail = OutApp.CreateItem(0)

'On Error Resume Next
            With OutMail
                '~~> Customize your email
                 .To = ""
                 .CC = sTo
                 .BCC = ""
                 .Subject = "typed subject1" & sSubject
                 .Body = ""

                 .Display '<~~ Change to .Send to actually send it
            End With
        End If
    Next i
End With
End Sub

This code opens up multiple windows in outlook with all the emails listed in K2:K59. For example, if three cells in J2:J59 have send reminder, i open 3 email windows with all the emails listed in the cc box, instead of either multiple windows with individual emails or one window with all the emails. I think I have to close the loop somehow but am not certain how! Thanks for your help.

Answer 1

Mail_Object.CreateItem(o)

Shouldn't that be

Mail_Object.CreateItem(0)

0 and not o

In the below code, you are not required to set a reference to MS Outlook Object Library. I am using Late Binding with MS Outlook.

Try this (Untested)

I have commented the code so you shall not have a problem understanding the code but if you do then simply post back :)

Option Explicit

Sub Sample()
    '~~> Excel Objects/Variables
    Dim ws As Worksheet
    Dim lRow As Long, i As Long

    '~~> Outlook Objects/Variables
    Dim OutApp As Object
    Dim OutMail As Object

    '~~> Set your worksheet here
    Set ws = ThisWorkbook.Sheets("Sheet1")
    '~~> Open Outlook
    Set OutApp = CreateObject("Outlook.Application")

    With ws
        '~~> Get last row from Col J as that is what we
        '~~> are going to check for the condition
        lRow = .Range("J" & .Rows.Count).End(xlUp).Row

        '~~> Loop through the rows
        For i = 2 To lRow
            If .Range("J" & i).Value = "Send Reminder" Then
                '~~> Create new email
                Set OutMail = OutApp.CreateItem(0)

                With OutMail
                    '~~> Customize your email
                    .To = ws.Range("K" & i).Value
                    .Subject = ws.Range("L" & i).Value
                    .Body = ws.Range("M" & i).Value

                    .Display '<~~ Change to .Send to actually send it
                End With
            End If
        Next i
    End With
End Sub

Answer 2

I did something similar yesterday, here is the code I used, hope it helps you out.

Sub EmailCopy()
Dim oApp, oMail As Object, X As Long, MyBody As String
    Application.ScreenUpdating = False
    On Error Resume Next
    Set oApp = CreateObject("Outlook.Application")
    For X = 2 To Range("A" & Rows.Count).End(xlUp).Row
        MyBody = Replace(Join(Application.Transpose(Range("E5:E" & Range("D" & Rows.Count).End(xlUp).Row - 1).Value), vbLf & vbLf), "<FirstName>", Range("B" & X).Text)
        MyBody = MyBody & vbLf & vbLf & Join(Application.Transpose(Range("E" & Range("D" & Rows.Count).End(xlUp).Row & ":E" & Range("E" & Rows.Count).End(xlUp).Row)), vbLf)
        Set oMail = oApp.CreateItem(0)
        With oMail
            .To = Range("A" & X).Text
            .cc = Range("E1").Text
            .Subject = Range("E2").Text
            .Body = MyBody
            .Attachments.Add Range("E3").Text
            .Display
            If UCase(Range("E4").Text) = "SEND" Then
                .Send
            ElseIf UCase(Range("E4").Text) = "DRAFT" Then
                .Save
                .Close False
            Else
                MsgBox "You need to choose Draft or Send in cell E4"
                End
            End If
        End With
        Application.ScreenUpdating = True
        Set oMail = Nothing
    Next
    Set oApp = Nothing
End Sub

Recipients go in Column A and First Name goes in column B, Any CC's go in E1, Subject goes in E2, Any attachment links go in E3, E4 is either Draft or Send to create a draft or do a send.

Then the message body goes in E5 down as far as you want, each line will be separated by a double return. Anywhere you use FirstName wrapped in greater than and less than signs the code will replace it with the person's First Name from column B.

Straight after that put the signature you want and put "Signature" in column D next to the start of it, this will be separated by single returns.

Answer 3

Since you have Outlook open you do not have to do anything complicated.

Set Mail_Object = GetObject(, "Outlook.Application")