Need Help with Excel Macro

Thank you for such a fast reply. This is the code I used but it did absolutely nothing. Didn't even put in my automatic email sent dates. What did I do wrong?

Sub Macro1()
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 Signature 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
If rngCell.Offset(0, 6) > 0 Then
ElseIf rngCell.Offset(0, 5) > Evaluate("Today() +7") And _
rngCell.Offset(0, 5).Value <= Evaluate("Today() +120") Then
r = rngCell.Row
rngCell.Offset(0, 6).Value = Date
Set OutMail = OutApp.CreateItem(0)
strBody = "According to my records, your " & Range("A" & r).Value & _
" contract is due for review " & rngCell.Offset(0, 5).Value & _
". It is important you review this contract ASAP and email me " & _
"with any changes made. If it is renewed, please fill out the " & _
"Contract Cover Sheet which can be found in the Everyone folder " & _
"and send me the cover sheet along with the new original contract."
SendToMail = Range("AH" & r).Value
EmailSubject = Range("A" & r).Value
'Signature = "C:\Documents and Settings\" & Environ("rmm") & _
"\Application Data\Microsoft\Signatures\rm.htm"
On Error Resume Next
With OutMail
.To = SendToMail
.Subject = EmailSubject
.Body = strBody
.Display ' You can use .Send
End With
Application.ScreenUpdating = False
End If
Next rngCell
Application.ScreenUpdating = True
End Sub