Ufdjrw

Image of Spreadsheet

I am trying set up email notifications to be sent people in my department whenever there is an upcoming due date within 7 days. Currently the issue is whenever I run the module, it sets up emails for anything that is before the due date. However, I want emails to be set up for projects that are due within 7 days. So if the project is 10 days out, I do not want an email sent, same project where it is already past due.

In addition, I would like the emails to be sent to the person responsible of the project, but not if they have indicated that they already completed the project in Column I.

I have Project names in Column B, Emails in Column F, Due Dates in Column H, and Column K would show "Email Sent" if the script sends the email. If the email has already been sent previously then it would skip that row.

Private Sub Workbook_Open()
 Dim OutApp As Object
 Dim OutMail As Object
 Dim lLastRow As Long
 Dim lRow As Long
 Dim sSendTo As String
 Dim sSendCC As String
 Dim sSendBCC As String
 Dim sSubject As String
 Dim sTemp As String

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

 ' Change the following as needed
 sSendCC = ""
 sSendBCC = ""
 sSubject = "Project Log Due Date Reached"

 lLastRow = Cells(Rows.Count, 3).End(xlUp).Row
 For lRow = 3 To lLastRow
 If Cells(lRow, 11) <> "Email Sent" Then
 If Cells(lRow, 8) - Date <= 7 And Cells(1Row, 8) - Date > 0 Then
 Set OutMail = OutApp.CreateItem(0)

 On Error Resume Next
 With OutMail
 .To = Cells(1Row, 6) 
 If sSendCC > "" Then .CC = sSendCC
 If sSendBCC > "" Then .BCC = sSendBCC
 .Subject = sSubject

 sTemp = "Hello!" & vbCrLf & vbCrLf
 sTemp = sTemp & "The due date has been reached "
 sTemp = sTemp & "for this project:" & vbCrLf & vbCrLf
 ' Assumes project name is in column B
 sTemp = sTemp & " " & Cells(lRow, 2)
 sTemp = sTemp & "Please take the appropriate"
 sTemp = sTemp & "action." & vbCrLf & vbCrLf
 sTemp = sTemp & "Thank you!" & vbCrLf

 .Body = sTemp
 ' Change the following to .Send if you want to
 ' send the message without reviewing first
 .Send
 End With
 Set OutMail = Nothing

 Cells(lRow, 11) = "Email Sent"
 Cells(lRow, 12) = "E-mail sent on: " & Now()
 End If
 End If
 Next lRow
 Set OutApp = Nothing
 End Sub

Please make a helper column in free column say Land put the formula =TODAY()-G2and draw down. Replace your following lines

 For lRow = 3 To lLastRow
 If Cells(lRow, 10) <> "Email Sent" Then
 If Cells(lRow, 7) <= 7 Then
 Set OutMail = OutApp.CreateItem(0)

With

For lRow = 3 To lLastRow
 If Cells(lRow, 10) <> "Email Sent" Then 
 If (Cells(lRow, 12) >= -7) And (Cells(lRow, 12) <= 0) Then
 Set OutMail = OutApp.CreateItem(0)

It works for me. You can also follow any other logic based on this logic.

Seany, Scott's right - take out the "On Error Resume Next" statement as this suppresses errors you'd rather see and troubleshoot at design time. And, you said Column F; which when using the Cells property, the column is the second parameter and you have "7" where "F" would be "6."

For comparing dates, I'd suggest DateDiff

Ex:

DateDiff("d", ws.Cells(1, 1).Value, ws.Cells(1, 1).Value + 7)