I am trying to get an email to automatically be produced and sent if Cell in Column U contains the words "Send Reminder"
I have attached the spreadsheet and the code I have been working on [from Ron Bruin site]for the email which I cannot get working
Also not convinced it would send automatically when the cell changes to contain required phrase
I'd be really grateful for some help with explaining what I have done wrong
Sub email()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList As String
Dim eSubject As String
Dim eBody As String
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Sheets("Sheet1").Select
lRow = Cells(Rows.Count, 12).End(xlUp).row '12 = email address from Column L
For i = 2 To lRow
If Left(Cells(i, 21), 12) = "Send Reminder" Then '21 = From Column U, 12 = email address from Column L
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
toList = Cells(i, 12) 'gets the recipient email address from Column L
eSubject = "Mower Service is due on" & Cells(i, 16) ' Next Service Date from Column P
eBody = "Dear " & Cells(i, 3) & " " & Cells(i, 5) & vbCrLf & vbCrLf & "Your " & Cells(i, 17) & "is due for its next service." & vbCrLf & vbCrLf & "Please call us on XXXXXXXXXXX or email us to arrange for your machines next service." & vbCrLf & vbCrLf & "The Cost of the service will be " & Cells(i, 19)
'3 = Title from Column C, 5 = Surname from Column E, 17 = Mower Type from Column Q, 19 = Cost from Column S
On Error Resume Next
With OutMail
.To = toList
.CC = ""
.BCC = ""
.Subject = eSubject
.Body = eBody
.BodyFormat = 1
.Display ' ********* Creates draft emails, to be removed when final testing complete
'.Send '********** To be set when final testing complete
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Cells(i, 21) = "Mail Sent " & Date + Time 'Marks the row as "email sent in Column U"
End If
Next i
ActiveWorkbook.Save
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
Spreadsheet is here: Contacts List.xlsm
Thank you so much for helping
Bookmarks