Automate email

I have a spreadsheet that I'm trying to automate emails. I've found a code, but can't quite seem to get it to work for me. I'm trying to generate an email 2 months prior to an employee's childline clearances and physicals expire (see attached.) Here's the code:

Option Explicit

Sub sendMail()
    Dim cl     As Range
    Dim rng    As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Const SendTo As String = "your email address"

    Set OutApp = CreateObject("Outlook.Application")

    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
    Set rng = Range(Cells(1, 2), Cells(Rows.Count, 2).End(xlUp))
    For Each cl In rng
        If cl.Value = Date + 30 Then
            'assumes name in Column A
            With OutMail
                .To = SendTo
                .Subject = cl.Value.Offset(0, -1) & " medical due"
                .Body = " add a message here"
                .Send
            End With
            End If
        Next cl
        Set OutMail = Nothing
        Set OutApp = Nothing
End Sub__________________

Any help would be appreciated