Need Help with Excel Macro

Diana703 

In another discussion, you asked

How would I modify the code you sent me to also include a specific hyperlink to the email that goes out? It would be a different hyperlink in each email just like the review date is also specific. Thank you.

If you include a URL complete with https:// or http:// in the body text of the email message, Outlook will automatically convert it to a hyperlink. The URL can come from the value of a cell, just like you get the type of contract from a cell.

You are the MASTER! I can't thank you enough! God bless you!

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

Gosh, you are going to wish you'd never heard of me but there is one thing that it has stopped doing. It used to put the date when the emails were sent in the Email Sent column but now it's not doing that. Can you fix that part of the code yet and then I promise to leave you alone. Thank you!