Automation Error 440 on Sending emails from excel

[abschy]

Hi all,

I have an excel file where i update context to bulk send emails as below:

The below vba helps to send 1 email per line based on the information input in the above table.

It used to work the past few months, but has suddenly come in with an automation error on the line "msg.Subject = sh.Range("H" & each_row).Value"

Any idea how to prevent this as this file will be used by multiple people to bulk send emails?

Thank you!

Sub send_email()
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Sheets("TRACKER")
    
    Dim OA As Object
    Dim msg As Object
    
    
    Dim each_row As Integer
    Dim last_row As Integer
    last_row = Application.WorksheetFunction.CountA(sh.Range("A:A"))
 
 
    For each_row = 2 To last_row
          Set OA = CreateObject("Outlook.Application")
          Set msg = OA.createitem(0)
          msg.To = sh.Range("D" & each_row).Value
          first_name = sh.Range("E" & each_row).Value
          last_name = sh.Range("F" & each_row).Value
          msg.cc = sh.Range("G" & each_row).Value
          msg.Subject = sh.Range("H" & each_row).Value
          msg.body = sh.Range("I" & each_row).Value
          date_to_send = sh.Range("J" & each_row).Value
          date_to_send = Format(date_to_send, "dd/mm/yyyy")
          Status = sh.Range("K" & each_row).Value
          current_date = Format(Date, "dd/mm/yyyy")
          If date_to_send = current_date Then
                If sh.Range("J" & each_row).Value <> "" Then
                Cells(each_row, 11).Value = "Sent"
                Content = Replace(msg.body, "<>", first_name + " " + last_name)
                msg.body = Content
                msg.send
                

            Else
                Cells(each_row, 11).Value = "Sent"
                Content = Replace(msg.body, "<>", first_name + " " + last_name)
                msg.body = Content
                msg.send
                
            End If
          End If
        
    Next each_row
    
    Set OA = Nothing
    Set msg = Nothing
    
    
End Sub

 

[JEC]

I think your complete code could be replaced by the code below. Maybe the error is gone too

Edit: made small change

Sub jec()
 Dim ar As Variant, i As Long
 ar = ThisWorkbook.Sheets("TRACKER").cells(1,1).CurrentRegion
 
 For i = 2 To UBound(ar)
   If ar(i, 10) = Date Then
       With CreateObject("outlook.application").createitem(0)
        .To = ar(i, 4)
        .cc = ar(i, 7)
        .Subject = ar(i, 8)
        .body = Replace(ar(i, 9), "<>", ar(i, 5) & " " & ar(i, 6))
        .display  '.send
      End With
      ar(i, 11) = "Sent"
   End If
 Next
 
 ThisWorkbook.Sheets("TRACKER").cells(1,1).CurrentRegion = ar
End Sub

 

[abschy]

I think your complete code could be replaced by the code below. Maybe the error is gone too

Edit: made small change

Sub jec()
 Dim ar As Variant, i As Long
 ar = ThisWorkbook.Sheets("TRACKER").cells(1,1).CurrentRegion
 
 For i = 2 To UBound(ar)
   If ar(i, 10) = Date Then
       With CreateObject("outlook.application").createitem(0)
        .To = ar(i, 4)
        .cc = ar(i, 7)
        .Subject = ar(i, 8)
        .body = Replace(ar(i, 9), "<>", ar(i, 5) & " " & ar(i, 6))
        .display  '.send
      End With
      ar(i, 11) = "Sent"
   End If
 Next
 
 ThisWorkbook.Sheets("TRACKER").cells(1,1).CurrentRegion = ar
End Sub

Thanks JEC for the help! the error is removed but it converts my table back to a range. is there any way to keep the table formatted as a table?

 

[JEC]

Yes there is, change to:
When you get an error on the second and last line, you need to write your table name here ListObjects("your table name").
Maybe it is not necessary

Sub jec()
 Dim ar As Variant, i As Long
 ar = ThisWorkbook.Sheets("TRACKER").ListObjects(1).DataBodyRange
 
 For i = 1 To UBound(ar)
   If ar(i, 10) = Date Then
       With CreateObject("outlook.application").createitem(0)
        .To = ar(i, 4)
        .cc = ar(i, 7)
        .Subject = ar(i, 8)
        .body = Replace(ar(i, 9), "<>", ar(i, 5) & " " & ar(i, 6))
        .display  '.send
      End With
      ar(i, 11) = "Sent"
   End If
 Next
 
 ThisWorkbook.Sheets("TRACKER").ListObjects(1).DataBodyRange = ar
End Sub