0

I am implementing a macro that checks column E for dates that are 7 days away from current date.

If cell date - current date = 7

then an email containing the row that has the matching cell, is sent to an email address to notify.

This is my coding it works succesfully, except for one issue.

Sub Workbook_Open()

Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range
Dim strHtmlHead As String
Dim strHtmlFoot As String
Dim strMsgBody As String
Dim strMsg As String
Dim objEmail As Object
Dim OutlookApp As Object
Dim OutlookMail As Object

'On Error GoTo ErrHnd

'only run if between midnight and 2AM
'If Hour(Now) < 2 Then

'setup basic HTML message header and footer


'setup start of body of message
strMsgBody = "The following task(s) are due in less than 7 days :"

'Worksheet name
With Worksheets("Sheet1")
'set start of date range
Set rngStart = .Range("E1")
'find end of date range
Set rngEnd = .Range("E" & CStr(Application.Rows.Count)).End(xlUp)

'loop through all used cells in column G
For Each rngCell In .Range(rngStart, rngEnd)
'test if date is equal to 7 days from today
If IsDate(rngCell.Value) Then
If rngCell.Value - Int(Now) = 7 Then
'add to message - use task name from column A (offset -3)
'change as required
strMsgBody = strMsgBody & "
" & "
" & "Task: " & rngCell.Offset(0, -3).Text _
& " is due on " & rngCell.Text & "
" & "
" & "Therefore please take necessary action"
End If
End If
Next rngCell

'Note last test time/date
rngEnd.Offset(1, -3) = Now
rngEnd.Offset(1, -3).NumberFormat = "dd/mm/yy"
End With

'put message together
strMsg = strMsgBody

'test message
'MsgBox strMsg

'create the e-mail object


Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)

With OutlookMail

.To = "[email protected]"
.CC = ""
.BCC = ""
.Subject = "Task Alert"
.HTMLBody = strMsg
.Send
End With


Set OutlookMail = Nothing
Set OutlookApp = Nothing

Application.DisplayAlerts = True
Application.ScreenUpdating = True


'remove the e-mail object

Exit Sub

'error handler
ErrHnd:
Err.Clear

End Sub

It works succesfully, except for one issue. When no dates fulfill the criteria

 rngCell.Value - Int(Now) = 7

An email is still generated without specifying any tasks. i want to edit the code so that no email is sent when there are no dates fullfilling the following criteria

rngCell.Value - Int(Now) = 7

How can i achieve this?

1 Answer 1

1

Create a boolean variable, set it to false before the loop and change it to true only when the comparison of dates is true. Then, before sending the email check the state of the variable. You can do these changes:

1 - Before the loop, above the line For Each rngCell In .Range(rngStart, rngEnd) put the line ValidDate = False.

2 - After If rngCell.Value - Int(Now) = 7 Then put the line ValidDate = True.

3 - Before the line Set OutlookApp = CreateObject("Outlook.Application") put the line: If ValidDate = True Then

4- Close the if block putting after .Send End With the line End If.

0

You must log in to answer this question.

Not the answer you're looking for? Browse other questions tagged .