Forum Discussion
Excel Code to Send/Not Send Email Based on Date
I need to insert code into my existing macro that will send email based on two things: 1) If Cell P (Email Sent) has a date in it, don't send any email; 2) Send only email if Cell O (Review Date) is within 120 days prior to the date in Cell O. Below is the code I have so far. I've attached the spreadsheet also. Can anyone help me with this? Thanks so much.
Sub Button1_Click()
Dim rngCell As Range
Dim Rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim strBody As String
Dim EmailSubject As String
Dim SendToMail As String
Dim r As Long
With ActiveSheet
If .FilterMode Then .ShowAllData
End With
Set OutApp = CreateObject("Outlook.Application")
Set Rng = Range("AH5", Cells(Rows.Count, "AH").End(xlUp))
For Each rngCell In Rng
r = rngCell.Row
Range("P" & r).Value = Date
Set OutMail = OutApp.CreateItem(0)
strBody = "According to my records, your " & Range("A" & r).Value & _
" contract is due for review. This contract expires " & Range("Q" & r).Value & _
". It is important you review this contract ASAP and email me " & _
"with any changes that are made. If it is renewed or rolled over, please fill out the " & _
"Contract Cover Sheet which can be found in the Everyone folder " & _
"and send me the Contract Cover Sheet along with the new original contract."
SendToMail = Range("AH" & r).Value
EmailSubject = Range("A" & r).Value
On Error Resume Next
With OutMail
.To = SendToMail
.CC = "email address removed for privacy reasons"
.BCC = ""
.Subject = EmailSubject
.Body = strBody
.Display ' You can use .Send
End With
Application.ScreenUpdating = False
'End If
Next rngCell
Application.ScreenUpdating = True
End Sub
I was misled by your description. Change the line
If Range("P" & r).Value = "" And Range("Q" & r).Value <> "" And Range("O" & r).Value >= Range("Q" & r).Value - 120 Thento
If Range("P" & r).Value = "" And Range("Q" & r).Value <> "" And Range("O" & r).Value <= Date Then
8 Replies
"Send only email if Cell O (Review Date) is within 120 days prior to the date in Cell O" cannot be correct. What should it be?
- You've got to be so tired of me! Bless your heart.
What I need is for it to not send an email if there is already a date in Email Sent in Column P (that is the date that is put in automatically when the email goes out) but to send the email for the cells that are empty (no date in them). At the same time, I need for it to only send emails to those where the Expiration Date in Column Q is a max of 120 days prior to that date. So you see, it has two conditions that need to be met prior to sending the email.
You are such a wonderful person. I'm embarrassed that I'm bothering you again but thank you for all you are doing.Try this:
Sub Button1_Click() Dim rngCell As Range Dim Rng As Range Dim OutApp As Object Dim OutMail As Object Dim strBody As String Dim EmailSubject As String Dim SendToMail As String Dim r As Long Application.ScreenUpdating = False With ActiveSheet If .FilterMode Then .ShowAllData End With Set OutApp = CreateObject("Outlook.Application") Set Rng = Range("AH5", Cells(Rows.Count, "AH").End(xlUp)) For Each rngCell In Rng r = rngCell.Row If Range("P" & r).Value = "" And Range("Q" & r).Value <> "" And Range("O" & r).Value >= Range("Q" & r).Value - 120 Then Range("P" & r).Value = Date Set OutMail = OutApp.CreateItem(0) strBody = "According to my records, your " & Range("A" & r).Value & _ " contract is due for review. This contract expires " & Range("Q" & r).Value & _ ". It is important you review this contract ASAP and email me " & _ "with any changes that are made. If it is renewed or rolled over, please fill out the " & _ "Contract Cover Sheet which can be found in the Everyone folder " & _ "and send me the Contract Cover Sheet along with the new original contract." SendToMail = Range("AH" & r).Value EmailSubject = Range("A" & r).Value On Error Resume Next With OutMail .To = SendToMail .CC = "email address removed for privacy reasons" .BCC = "" .Subject = EmailSubject .Body = strBody .Display ' You can use .Send End With End If Next rngCell Application.ScreenUpdating = True End Sub
