E-mail Sending Loop

[cwhaley1]

I have written a probably fairly basic macro which calls up the new message dialogue in MS Outlook. It then populates that dialogue with data contained within a spreadsheet (see code below). It does work well, in that whichever e-mail address the user selects (which therefore makes that cell the active cell), VBA will use that cell as the “to” field and then “cc” in the value of the cell one to the right (another e-mail address). Unfortunately this has to be done for each and every person who needs to be e-mailed, often up to 40 or 50 people.

What I’d like to do (and what I’ve failed at so far) is have VBA loop through each row with values in, and enter those values into the relevant Outlook field, ending if there is an error. The only fields which will change are the “to” and “cc” fields, as the e-mail address the e-mail is sent from never changes, nor does the body or subject. In short, I’m sending a e-mail to each person in a table.

I’ve tried to do it but at best all I can get VBA to do is start an endless loop of opening the new message dialogue, with no values entered. Does anybody have any pointers?


The source table:

Enter Name Here	Supervisor	E-mail address	Supervisor e-mail address
Value entered here is the source of the formula on the right	Name, result of INDEX formula	This is the 'to' field (result of INDEX formula)	This is the 'cc' field (result of INDEX formula)

My current code:

Sub Email_Timesheet()

    On Error Resume Next
    Dim OutApp As Variant
    Dim OutMail As Variant
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .SentOnBehalfOfName = "sharedinbox@example.com" 'this is the "from" field
        .To = Range(Selection.Address)
        .CC = Range(Selection.Address).offset(, 1) 'this enters the value in the column one to the right of the selected e-mail address
        .Subject = "Late Timesheet"
        .body = Range("J1") 'this references the cell where the body of the e-mail is written
       On Error Resume Next
         On Error GoTo 0
         .Save
        .Display
        '.send '<<<<<to send without reviewing first, remove the "'"
    End With
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing


End Sub

 

[mumps]

Assuming the email addresses are in column C starting in row 2, try:

Sub Email_Timesheet()
    Application.ScreenUpdating = False
    Dim OutApp As Object, OutMail As Object, email As Range
    Set OutApp = CreateObject("Outlook.Application")
    For Each email In Range("C2", Range("C" & Rows.Count).End(xlUp))
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .SentOnBehalfOfName = "sharedinbox@example.com" 'this is the "from" field
            .To = email
            .CC = email.Offset(, 1) 'this enters the value in the column one to the right of the selected e-mail address
            .Subject = "Late Timesheet"
            .body = Range("J1") 'this references the cell where the body of the e-mail is written
             .Save
            .Display
            '.send '<<<<<to send without reviewing first, remove the "'"
        End With
    Next email
    Application.ScreenUpdating = True
End Sub

 

[cwhaley1]

Assuming the email addresses are in column C starting in row 2, try:

Sub Email_Timesheet()
    Application.ScreenUpdating = False
    Dim OutApp As Object, OutMail As Object, email As Range
    Set OutApp = CreateObject("Outlook.Application")
    For Each email In Range("C2", Range("C" & Rows.Count).End(xlUp))
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .SentOnBehalfOfName = "sharedinbox@example.com" 'this is the "from" field
            .To = email
            .CC = email.Offset(, 1) 'this enters the value in the column one to the right of the selected e-mail address
            .Subject = "Late Timesheet"
            .body = Range("J1") 'this references the cell where the body of the e-mail is written
             .Save
            .Display
            '.send '<<<<<to send without reviewing first, remove the "'"
        End With
    Next email
    Application.ScreenUpdating = True
End Sub

That does exactly what I needed it to do, thank you! I was using "C2:2" as my range which wasn't working.

One problem, however... after the macro has done what I need, it returns a 440 run-time error (object does not support this method) on the line ".To = email". I can end the macro and run it again if needed, but there will be users who will be scared by the message.

 

[mumps]

Delete any formulas at the bottom of column C that do not have any Supervisor returned in column B. In other words, any formula cells at the bottom of your sheet that don't return a valid result have to be deleted.

 

[cwhaley1]

Delete any formulas at the bottom of column C that do not have any Supervisor returned in column B. In other words, any formula cells at the bottom of your sheet that don't return a valid result have to be deleted.

Thank you, that solved the problem – I added a macro to clear any cells with errors in them. After that has been ran, I’ve added another command button called “Reset Sheet” which links to a macro to remove all data from a range and then re-enter the formulae.

Thanks for your solution to this.

 

[mumps]

You are very welcome.