Need Help with Excel Macro

Diana703 

Try this version. You can also try uncommenting the If ... and End If lines - I think they should work correctly now.

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
        'If Range("P" & r).Value = "" And _
                Range("O" & r).Value > Date + 7 And _
                Range("O" & r).Value <= Date + 120 Then
            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 " & 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
            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