Stephen1313
New Member
- Joined
- Jan 28, 2021
- Messages
- 8
- Office Version
- 365
- Platform
- Windows
I have a task tracker worksheet that I use with my staff. I have added quite a bit of functionality to it and have been working on a final item to automatically send email reminders based on a days left counter that uses the formula in the H column cells : '=[@[Due Date]]-TODAY()' which is essentially takes the due dates contained in column G and subtracts them from todays date and puts the value of days left into column G. I have set up a MACRO that searches Column H for specific days remaining as the trigger to send a reminder email (specifically 14, 7, and 0) as well as placing the status of emails sent into column M. That Macro works perfectly but I want to know if there is a way to make it so this macro works behind the scenes based on the counter as the days change which is automatic or at least appears so when i open excel. Is there a way to write this in VBA maybe using event handlers? Can this be done with out the workbook being open? Here is a image of my sheet and the code below is the email MACRO. Thanks in advance!
VBA Code:
Sub Email_Reminder()
Sheets("Project Tracker ").Select
Dim OutApp As Object
Dim OutMail As Object
Dim strto As String, strcc As String, strbcc As String
Dim strsub As String, strbody As String
Dim FormulaRange As Range
Dim NotSentMsg As String
Dim MyMsg As String
Dim SentMsg As String
Dim FirstMsg As String
Dim SecondMsg As String
Dim FinalMsg As String
Dim VarRange As String
Dim last_row As Long
NotSentMsg = "No Reminder Sent"
SentMsg = "Sent"
FirstMsg = "1st Reminder Sent"
SecondMsg = "2nd Reminder Sent"
FinalMsg = "Final Reminder Sent"
last_row = Cells(Rows.Count, 8).End(xlUp).Row
'Set the range with Formulas that you want to check
Set FormulaRange = Range(Cells(2, 8), Cells(last_row, 8))
On Error GoTo EndMacro:
For Each Formulacell In FormulaRange.Cells
With Formulacell
If .Value = 14 Then
MyMsg = "First Reminder Sent"
If .Offset(0, 5).Value = NotSentMsg Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strto = Cells(Formulacell.Row, "K").Value
strcc = Cells(Formulacell.Row, "L").Value
strbcc = ""
strsub = "Task Tracker Automatic First Reminder"
strbody = "Hi " & Cells(Formulacell.Row, "C").Value & vbNewLine & vbNewLine & _
"This is a reminder that task " & Cells(Formulacell.Row, "A").Value & _
vbNewLine & vbNewLine & "is coming due in 14 days!"
OutMail.to = strto
OutMail.CC = strcc
OutMail.BCC = strbcc
OutMail.Subject = strsub
OutMail.Body = strbody
'You can add a file to the mail like this
'.Attachments.Add ("C:\test.txt")
OutMail.Display ' or use .Send
Set OutMail = Nothing
Set OutApp = Nothing
End If
Else
If .Value = 7 Then
MyMsg = SecondMsg
If .Offset(0, 5).Value = FirstMsg Or .Offset(0, 5).Value = NotSentMsg Then
'Call Mail_with_outlook2
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strto = Cells(Formulacell.Row, "K").Value
strcc = Cells(Formulacell.Row, "L").Value
strbcc = ""
strsub = "Task Tracker Automatic Second Reminder"
strbody = "Hi " & Cells(Formulacell.Row, "C").Value & vbNewLine & vbNewLine & _
"This is a reminder that task " & Cells(Formulacell.Row, "A").Value & _
vbNewLine & vbNewLine & "is coming due 7 days!"
OutMail.to = strto
OutMail.CC = strcc
OutMail.BCC = strbcc
OutMail.Subject = strsub
OutMail.Body = strbody
'You can add a file to the mail like this
'.Attachments.Add ("C:\test.txt")
OutMail.Display ' or use .Send
Set OutMail = Nothing
Set OutApp = Nothing
End If
Else
If .Value = 0 Then
MyMsg = FinalMsg
If .Offset(0, 5).Value = SecondMsg Or .Offset(0, 5).Value = FirstMsg Or .Offset(0, 5).Value = NotSentMsg Then
'Call Mail_with_outlook3
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strto = Cells(Formulacell.Row, "K").Value
strcc = Cells(Formulacell.Row, "L").Value
strbcc = ""
strsub = "Task Tracker Automatic Final Reminder"
strbody = "Hi " & Cells(Formulacell.Row, "C").Value & vbNewLine & vbNewLine & _
"This is a reminder that task " & Cells(Formulacell.Row, "A").Value & _
vbNewLine & vbNewLine & "is due today!"
OutMail.to = strto
OutMail.CC = strcc
OutMail.BCC = strbcc
OutMail.Subject = strsub
OutMail.Body = strbody
'You can add a file to the mail like this
'.Attachments.Add ("C:\test.txt")
OutMail.Display ' or use .Send
Set OutMail = Nothing
Set OutApp = Nothing
End If
Else
MyMsg = NotSentMsg
End If
End If
End If
Application.EnableEvents = False
.Offset(0, 5).Value = MyMsg
Application.EnableEvents = True
End With
Next Formulacell
ExitMacro:
Exit Sub
EndMacro:
Application.EnableEvents = True
MsgBox "Some Error occurred." _
& vbLf & Err.Number _
& vbLf & Err.Description
End Sub