Excel2010 VBA for reminder Outlook2016 emails, three months before review date

[Swilliams4]

Hallo, I'm an admin and VBA newbie, trying to send automated reminder emails from Excel 2010 via Outlook, three months before the review date (in Column C).
I've managed to send an email from Excel But can't get any further, have tried the YouTube videos but am baffled and was advised to try this forum instead?
Thanks very much in advance

 

[John_w]

Welcome to MrExcel forums.

See if this basic macro gets you started. The macro operates on "Sheet1" starting at row 2. To ensure that each reminder email is sent only once, the macro puts the date each email was sent in column D and sends the email only if this column's cell is empty. Change column "D" in the code if necessary. Also, rather than checking for 3 months difference between the current date and the future review date (which would be If DateDiff("m", Date, .Cells(r, "C").Value) = 3), the macro checks for a difference of 90 to 96 days (i.e. a 7-day range). All the email details (subject, body text, etc.) are hard-coded, but the macro could be easily changed to get these from cells.

Option Explicit

Public Sub Check_Send_Reminders()

    Dim lastRow As Long, r As Long
   
    With Worksheets("Sheet1")
        lastRow = .Cells(.Rows.Count, "C").End(xlUp).row
        For r = 2 To lastRow
            If DateDiff("d", Date, .Cells(r, "C").Value) >= 90 And DateDiff("d", Date, .Cells(r, "C").Value) <= 96 And IsEmpty(.Cells(r, "D").Value) Then
                Send_Outlook_Email "Reminder", "Email body text", "email.address1@email.com", "email.address2@email.com"
                .Cells(r, "D").Value = Date
            End If
        Next
    End With

End Sub

Private Sub Send_Outlook_Email(subject As String, body As String, ToEmail As String, CCEmail As String)

    Static OutlookApp As Object 'Outlook.Application
    Dim objMail As Object 'Outlook.MailItem
   
    If OutlookApp Is Nothing Then
        On Error Resume Next
        Set OutlookApp = GetObject(, "Outlook.Application")
        On Error GoTo 0
        If OutlookApp Is Nothing Then Set OutlookApp = CreateObject("Outlook.Application")  'New Outlook.Application
    End If
   
    Set objMail = OutlookApp.CreateItem(0)  '0 = olMailItem
    objMail.subject = subject
    objMail.body = body
    objMail.To = ToEmail
    objMail.CC = CCEmail
    objMail.Send

End Sub