VBA Code to automatically send an email when a due date approaches

Hello,

First post here- having a bit of trouble working through this VBA code.
As preface to this probably really ugly code- i've been VBA coding for 2 days now haha.

My goal is to have a code scan through Column J for text saying "Send Reminder"
Then it would see if the same row's column L is Blank.
If so, it would read if the date in Column D is Less than or equal to 14 days away from today.

If all of the above was true, it would proceed to open a new Email using the following Information all from the same row as the detected "send Reminder"

Email address from Column K
Subject will be: Contract [Value from Column C] will be expiring on [Value from Column D]
Body will be: Dear [Value from Column G] please update me on the status of this contract

Afterwards, it will then mark the date the email was sent in Column L to make sure another email reminder will not be sent out.

All Desired information BEGINS on row 4, I'm hoping none of the above rows will be included.


Below is the current code I'm using - It keeps looping over the same cells sadly.

Sub TEstSend()
Dim RowCount As Long
Dim ColCount As Long
Dim tmpstr As String

For RowCount = 1 To 14
tmpstr = ""
For ColCount = 1 To 14
tmpstr = tmpstr & Cells(RowCount, ColCount)
Next ColCount
If tmpstr <> "" Then

Dim i As Long
Dim OutApp, OutMail As Object
Dim strto, strcc, strbcc, strsub, strbody As String

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon



For i = 3 To 10
If Cells(i, 4) - 14 < Date Then
If Cells(i, 10) = "Send Reminder" Then
Set OutMail = OutApp.CreateItem(0)
strto = Cells(i, 11).Value 'email address
strsub = "Contract " & Cells(i, 3).Value & " is expiring on " & Cells(i, 4).Value 'email subject
strbody = "Dear " & Cells(i, 7).Value & vbNewLine & "please update me on this contract's status" 'email body
With OutMail
.To = strto
.Subject = strsub
.Body = strbody
.display

On Error Resume Next
Cells(i, 12) = "Mail Sent " & Now()
Cells(i, 13) = "Reminder Sent"

End With
End If
End If
Next

Set OutMail = Nothing
Set OutApp = Nothing

End If

Next



End Sub


Thank you all!

Hi there,

See if the following code does what you need:

Option Explicit


Sub TestSend()

    Const sCOLUMN__SEND_REMINDER    As String = "J"
    Const sCOLUMN__REMINDER_SENT    As String = "L"
    Const sCOLUMN__REMINDER_DATE    As String = "M"
    Const sCOLUMN__CONTACT_NAME     As String = "G"
    Const sCOLUMN__CONTRACT_NO      As String = "C"
    Const sCOLUMN__EXPIRY_DATE      As String = "D"
    Const sCOLUMN__ADDRESS          As String = "K"

    Const iMAXIMUM_NO_OF_ROWS       As Integer = 100
    Const iFIRST_ROW_NO             As Integer = 4
    Const sSHEET_NAME               As String = "Sheet1"
    Const iMAIL_ITEM                As Integer = 1

    Dim objMailItem                 As Object
    Dim objOutlook                  As Object

    Dim sSubject                    As String
    Dim iRowNo                      As Integer
    Dim sBody                       As String
    Dim sTo                         As String
    Dim wks                         As Worksheet

    Set wks = ThisWorkbook.Worksheets(sSHEET_NAME)

    Set objOutlook = CreateObject("Outlook.Application")
        objOutlook.Session.Logon

    For iRowNo = iFIRST_ROW_NO To (iFIRST_ROW_NO + iMAXIMUM_NO_OF_ROWS - 1)

        With wks

            If .Range(sCOLUMN__CONTRACT_NO & iRowNo).Value <> vbNullString Then

                If .Range(sCOLUMN__EXPIRY_DATE & iRowNo) - 14 < Date Then

                    If .Range(sCOLUMN__SEND_REMINDER & iRowNo) = "Send Reminder" And _
                       .Range(sCOLUMN__REMINDER_SENT & iRowNo) = vbNullString Then

                        sTo = .Range(sCOLUMN__ADDRESS & iRowNo).Value

                        sSubject = "Contract " & .Range(sCOLUMN__CONTRACT_NO & iRowNo).Value & _
                                   " is expiring on " & .Range(sCOLUMN__EXPIRY_DATE & iRowNo).Value

                        sBody = "Dear " & .Range(sCOLUMN__CONTACT_NAME & iRowNo).Value & _
                                 vbNewLine & _
                                "Please update me on this contract's status"

                        Set objMailItem = objOutlook.CreateItem(iMAIL_ITEM)

                        With objMailItem
                            .To = sTo
                            .Subject = sSubject
                            .Body = sBody
                            .Display
                        End With

                        .Range(sCOLUMN__REMINDER_DATE & iRowNo) = "Mail Sent " & Now()
                        .Range(sCOLUMN__REMINDER_SENT & iRowNo) = "Reminder Sent"

                    End If

                End If

            End If

        End With

    Next iRowNo

    Set objMailItem = Nothing
    Set objOutlook = Nothing
    Set wks = Nothing

End Sub

The highlighted values can be changed to suit your own requirements. Specifying the various column letters as constants at the start of the routine makes life a bit easier if the layout of your worksheet ever changes.

I would suggest combining the "Reminder Sent" and "Reminder Date" cells into a single cell containing "Reminder Sent" plus the date.


Hope this help - please let me know how you get on.

Regards,

Greg M