Send Emails once expiry date is reached, and generate report based on emails sent

[demonicscorpion]

Good Day to all excel gurus out there

this forum is really a vault of knowledge has really helped me out greatly in the past

i need your wisdom guys to help me out with enhancing my code to carry out 2 functions.

let me explain what i am trying to do, and what i have done so far.

I have a workbook that contains multiple sheets for different clients, and each sheet has details of documents relating to each client documentations and expiry date for these documents. each of these sheet has a an RM that is responsible to follow up. All the sheets are identical formatting wise, number of columns number of rows.

What i am trying to do is run a macro that scans through the expiry date column of each sheet, and scans all the rows till it cannot find any more dates. It is supposed to check which documents is expiring within the next 30 days and send a first reminder to the respective RM whose email is also included in the sheet with specific details about the client and the type of document that is about to expire. Also when you run the macro again if no reminder 1 was sent to send an email and fill in the current date when reminder 1 is sent. If reminder 1 already has a date to send a 2nd reminder and fill it in with todays date. for this part i have already written the code and it is working beautifully.. please see the code below.

Now what i want to do is if any of the expiry dates have been updated and therefore it does not fall within the 30 days expiry period, on the execution of the macro it should clear the reminders automatically and reset the cell values respectively.

Also everytime the macro runs and it detects an expired documents and send an email i want to be able to generate a report based on the emails that were sent.

Lets say the macro generated 10 emails for 10 expired documents sent to 5 different RMS, i want to be able to see RM Name, Document Name, Expiry Date, date reminder was sent. All these values are available in the actual sheet, i just need to be able to reference it once the macro is executed. Somehow try to integrate it into the originally existing code.

Id greatly appreciate any help you guys can provide ive been trying to sort this out for a few weeks now my brain is fried



Option Explicit

Public Sub SendReminderNotices()

Dim WS_Count As Integer
Dim z As Integer

' Set WS_Count equal to the number of worksheets in the active
' workbook.
WS_Count = ActiveWorkbook.Worksheets.Count

' Begin the loop.
For z = 1 To WS_Count

' Insert your code here.

' ****************************************************************
' Define Variables
' ****************************************************************
Dim wkbReminderList As Workbook
Dim wksReminderList As Worksheet
Dim lngNumberOfRowsInReminders As Long
Dim I As Long

' ****************************************************************
' Set Workbook and Worksheet Variables
' ****************************************************************
Set wkbReminderList = ActiveWorkbook
Set wksReminderList = ActiveWorkbook.Worksheets(z)

' ****************************************************************
' Determine How Many Rows Are In the Worksheet in Column A
' ****************************************************************
lngNumberOfRowsInReminders = wksReminderList.Cells(Rows.Count, "H").End(xlUp).Row

' ****************************************************************
' For Any Items That Don't Have A Date In Column K
' Check To See If The Reminder Is Due.
'
' If Reminder Is Due, then Send An Email.
' If Successful, Log The Date Sent in Column K
' ****************************************************************

For I = 10 To lngNumberOfRowsInReminders
' ****************************************************************
' Check If The Item Was Already Emailed
' ****************************************************************
If wksReminderList.Cells(I, 10) <> "" Then
If wksReminderList.Cells(I, 11) = "" Then
' ****************************************************************
' If A Reminder Was Not Sent, Then Check To See if Within 30 Days
' ****************************************************************
If wksReminderList.Cells(I, 8) <= Date + 30 Then
' ****************************************************************
' Send An Email Message And Check To See That It Is Successful
' ****************************************************************
If SendAnOutlookEmail(wksReminderList, I) Then
wksReminderList.Cells(I, 11) = Date 'Indicate That Reminder1 Was Successful
End If
End If
' ****************************************************************
' Second Reminder Date Check
' ****************************************************************
Else
If wksReminderList.Cells(I, 11) <> "" Then
If wksReminderList.Cells(I, 12) = "" Then
If wksReminderList.Cells(I, 8) <= Date Then
If SendAnOutlookEmail2(wksReminderList, I) Then
wksReminderList.Cells(I, 12) = Date 'Indicate That Reminder2 Was Successful
End If
End If
End If
End If
End If
End If
Next I

' The following line shows how to reference a sheet within
' the loop by displaying the worksheet name in a dialog box.


Next z


End Sub


Private Function SendAnOutlookEmail(WorkSheetSource As Worksheet, RowNumber As Long) As Boolean




Dim strMailToEmailAddress As String
Dim strSubject As String
Dim strBody As String
Dim OutApp As Object
Dim OutMail As Object



SendAnOutlookEmail = False

strMailToEmailAddress = WorkSheetSource.Cells(3, 6)
strSubject = "Reminder Notification" & " - CIF " & WorkSheetSource.Cells(3, 4) & " - " & WorkSheetSource.Cells(2, 4)
strBody = WorkSheetSource.Cells(RowNumber, 6) & " - " & WorkSheetSource.Cells(RowNumber, 9) & " is expiring on " & Format(WorkSheetSource.Cells(RowNumber, 8), "DD-MM-YYYY")

' ****************************************************************
' Create The Outlook Mail Object
' ****************************************************************
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

' ****************************************************************
' Send The Email
' ****************************************************************
On Error GoTo ErrorOccurred
With OutMail
.To = strMailToEmailAddress
.Subject = strSubject
.Body = strBody
.Send
End With

' ****************************************************************
' Mail Was Successful
' ****************************************************************
SendAnOutlookEmail = True

Continue:
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Exit Function

' ****************************************************************
' Mail Was Not Successful
' ****************************************************************
ErrorOccurred:

Resume Continue



End Function


Private Function SendAnOutlookEmail2(WorkSheetSource As Worksheet, RowNumber As Long) As Boolean




Dim strMailToEmailAddress As String
Dim strSubject As String
Dim strBody As String
Dim OutApp As Object
Dim OutMail As Object



SendAnOutlookEmail2 = False

strMailToEmailAddress = WorkSheetSource.Cells(3, 6)
strSubject = " 2nd Reminder Notification" & " - CIF " & WorkSheetSource.Cells(3, 4) & " - " & WorkSheetSource.Cells(2, 4)
strBody = WorkSheetSource.Cells(RowNumber, 6) & " - " & WorkSheetSource.Cells(RowNumber, 9) & " is expiring on " & Format(WorkSheetSource.Cells(RowNumber, 8), "DD-MM-YYYY")

' ****************************************************************
' Create The Outlook Mail Object
' ****************************************************************
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

' ****************************************************************
' Send The Email
' ****************************************************************
On Error GoTo ErrorOccurred
With OutMail
.To = strMailToEmailAddress
.Subject = strSubject
.Body = strBody
.Send
End With

' ****************************************************************
' Mail Was Successful
' ****************************************************************
SendAnOutlookEmail2 = True

Continue:
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Exit Function

' ****************************************************************
' Mail Was Not Successful
' ****************************************************************
ErrorOccurred:

Resume Continue



End Function

******************************************---------------------------------*******************************