The macro below is designed to send an e-mail 6, 4, and 3 months before its expiration date (column 14).

There needs to be one more criteria: Macro should send e-mail only when any cell in Column A contains text ACTIVE.

Is there a way to include that in the code?

Thanks!

Sub EmailReminder()
Dim FinalRow As Long, i As Long, j As Long
Dim OutApp As Object, OutMail As Object, x As Long

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

For i = 2 To FinalRow
    For j = 15 To 17
        If Cells(i, j).Value = Date Then
            x = x + 1
            strBodyMonths = "six"
            
            If j = 16 Then
                strBodyMonths = "four"
            ElseIf j = 17 Then
                strBodyMonths = "three"
            End If
            
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)
            
            With OutMail
                .To = "email@google.com"
                .Subject = "Contract Expiration Notice for " & Cells(i, 2)
                .Body = "Hello Joy, 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
            Set OutMail = Nothing
        End If
    Next
Next

If x = 0 Then
    MsgBox "There are no contracts expiring 6, 4, or 3 months from today!", vbInformation, "Status"
End If

End Sub