Send Email Based on 2 Dates

Hello all, this is my first thread and have looked at others but can't find a solution.

I need a VBA code that sends an email to the same email address every time TODAY() date matches the date on 2 difference cells.

Please refer to the attached file:

If TODAY() matches any date in Column D (i.e. D2 [10/1/2015]):

Email should read: Hello John Doe, the contract for School Board Of Mdc (A2) will expire in four months from today, TODAY() on 2/1/2016 (B2).

If TODAY() matches any date in Column C (i.e. C2 [8/1/2015]):

Email should read: Hello John Doe, the contract for School Board Of Mdc (A2) will expire in six months from today, TODAY() on 2/1/2016 (B2).

I am using Outlook 2013 and Excel 2013 on Windows 7 Professional.

Thanks. I appreciate your help!

How about:

Sub EmailReminder()

For i = 2 To 5
    For j = 3 To 4
    
    If Cells(i, j).Value = Date Then

    strBodyMonths = "six"
    If j = 4 Then strBodyMonths = "four"

    Dim OutApp As Object
    Dim OutMail As Object
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
        With OutMail
            .To = "[email protected]"
            .Subject = "Expiration Notice"
            .Body = "Hello John Doe, the contract for " & Cells(i, 1) & _
                    "will expire in " & strBodyMonths & " months from today, " & Date & " on " & Cells(i, 2) & "."
            .Send
        End With

    Set OutMail = Nothing
    Next
Next

End Sub

Oops. Missed an End If.

Sub EmailReminder()

For i = 2 To 5
    For j = 3 To 4
    
    If Cells(i, j).Value = Date Then

    strBodyMonths = "six"
    If j = 4 Then strBodyMonths = "four"

    Dim OutApp As Object
    Dim OutMail As Object
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
        With OutMail
            .To = "[email protected]"
            .Subject = "Expiration Notice"
            .Body = "Hello John Doe, the contract for " & Cells(i, 1) & _
                    "will expire in " & strBodyMonths & " months from today, " & Date & " on " & Cells(i, 2) & "."
            .Send
        End With

    End If
    Set OutMail = Nothing
    Next
Next

End Sub

When I transfer the code to the real spreadsheet I'm working with I get a Type Mismatch error. Please take a look at the code:

Sub EmailReminder()

FinalRow = Cells(Rows.Count, 2).End(xlUp).Row

For i = 2 To FinalRow
    For j = 15 To 17
    
    If Cells(i, j).Value = Date Then

    strBodyMonths = "six"
    If j = 16 Then strBodyMonths = "four"
    If j = 17 Then strBodyMonths = "three"

    Dim OutApp As Object
    Dim OutMail As Object
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
        With OutMail
            .To = "[email protected]"
            .Subject = "Contract Expiration Notice for " & Cells(i, 2)
            .Body = "Hello Ron, the contract for " & Cells(i, 2) & _
                    " will expire in " & strBodyMonths & " months from today, " & Date & " on " & Cells(i, 14) & ". Have a wonderful day!"
            .Send
        End With

    End If
    Set OutMail = Nothing
    Next
Next

End Sub

Thank you again!

The code should let you know which line error'ed out.

The most likely culprit is

If Cells(i, j).Value = Date Then

if the value being compared is an error itself.

Try using

    If IsNumeric(Cells(i, j).Value) Then
        If Cells(i, j).Value = Date Then

        End If
    End If

to try to supress the error.