Excel Code to Send/Not Send Email Based on Date

Copper Contributor

Sep 13, 2022

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.

HansVogelaar

MVP

Sep 13, 2022

Diana703

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

Diana703
Copper Contributor
Sep 13, 2022
It's still giving me the email for the contract that doesn't expire until 9/13/23. It should ignore that one until its 120 days prior to that date.

HansVogelaar
MVP
Sep 13, 2022
Diana703

You write "where the Expiration Date in Column Q is a max of 120 days prior to that date."

What is that date? The date in column O?
- Diana703
  Copper Contributor
  Sep 13, 2022
  Both of these dates vary. The Review Date (Column O) is automatic with a simple formula (=Q5-120). The Expiration Date (Column Q) varies for each contract.

Forum Discussion

Excel Code to Send/Not Send Email Based on Date

Resources