Hi all,
Its been a while since I've posted anything so apologies if my upfront info is lacking (happy to add more if requested), but I'll try my best to describe the challenge I've got.
Objective - Auto send an email with various info points from excel when a target date is reached in a specific row.
Summary - I've set a trigger date using the formula =TODAY() to always show todays date and is activated when another cell in that row matches the value. I've also got cells around this date assigned to work tasks which will, at some point, match the date in the =TODAY() formula, and then an IF(task_date=TODAY TRIGGER, "EMAIL",0) will appear in a corresponding cell row of that tasks line. i.e task 1 is set for 6 weeks from today, and when the date eventually matches the =TODAY() formula date in 6 weeks time, it will then activate the IF statement and this is what I'd like to trigger the VBA code to send an email to me.
So in an ideal world, column B is the manual input date (delivered date) field that will trigger all cells in that row, and if the task is located in column A, the task due date is column F, the =TODAY() date trigger is in column G and the IF statement "EMAIL" trigger is in column H. Once the task due date matches the =TODAY() formula, it activates the IF statement and triggers the email into a send/ display option with the appropriate information that corresponds to that row from the desired col/ row locations and insert this info into the body of the email as outlined in the code and ref points of the sheet below.
The below VBA code is what I have so far and I'm struggling with the range setup and how to get the cell values into the body of the email. Thanks in advance, and please ask for anymore info if required. I've attached a pic of the sheet and the VBA code for visual representation.
Dim xRg As Range
'Update by Extendoffice 2018/3/7
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Cells.Count = 0 Then Exit Sub
Set xRg = Intersect(Range("U2:U200000"), Target)
If xRg Is Nothing Then Exit Sub
If IsNumeric(Target.Value) And Target.Value = "EMAIL" Then
Call Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
'THE BELOW IS THE EMAIL BODY I'D LIKE POPULATED WITH CELL INFORMATION THAT CORRESPONDS TO THE ROW THAT HAS BEEN ACTIVATED BY THE FORMULAS
xMailBody = "Good day," & vbNewLine & vbNewLine & _
"Upon reaching its validation due date, (task_name) is now ready for validation in week (validation_week)." & vbNewLine & vbNewLine & _
"Please arrange a slide and business case to showcase the benefits" & vbNewLine & vbNewLine & _
"Kind Regards,"
On Error Resume Next
With xOutMail
.To = "email1@email"
.CC = ""
.BCC = ""
.Subject = "Validation items are due (TEST PLEASE IGNORE)"
.Body = xMailBody
'.Attachments.Add ActiveWorkbook.FullName
.Display
'or use
'.Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
Private Sub Workbook_Open()
Sheets("Sheet12").Range("U2:U200000").Value = "EMAIL"
End Sub
Its been a while since I've posted anything so apologies if my upfront info is lacking (happy to add more if requested), but I'll try my best to describe the challenge I've got.
Objective - Auto send an email with various info points from excel when a target date is reached in a specific row.
Summary - I've set a trigger date using the formula =TODAY() to always show todays date and is activated when another cell in that row matches the value. I've also got cells around this date assigned to work tasks which will, at some point, match the date in the =TODAY() formula, and then an IF(task_date=TODAY TRIGGER, "EMAIL",0) will appear in a corresponding cell row of that tasks line. i.e task 1 is set for 6 weeks from today, and when the date eventually matches the =TODAY() formula date in 6 weeks time, it will then activate the IF statement and this is what I'd like to trigger the VBA code to send an email to me.
So in an ideal world, column B is the manual input date (delivered date) field that will trigger all cells in that row, and if the task is located in column A, the task due date is column F, the =TODAY() date trigger is in column G and the IF statement "EMAIL" trigger is in column H. Once the task due date matches the =TODAY() formula, it activates the IF statement and triggers the email into a send/ display option with the appropriate information that corresponds to that row from the desired col/ row locations and insert this info into the body of the email as outlined in the code and ref points of the sheet below.
The below VBA code is what I have so far and I'm struggling with the range setup and how to get the cell values into the body of the email. Thanks in advance, and please ask for anymore info if required. I've attached a pic of the sheet and the VBA code for visual representation.
Dim xRg As Range
'Update by Extendoffice 2018/3/7
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Cells.Count = 0 Then Exit Sub
Set xRg = Intersect(Range("U2:U200000"), Target)
If xRg Is Nothing Then Exit Sub
If IsNumeric(Target.Value) And Target.Value = "EMAIL" Then
Call Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
'THE BELOW IS THE EMAIL BODY I'D LIKE POPULATED WITH CELL INFORMATION THAT CORRESPONDS TO THE ROW THAT HAS BEEN ACTIVATED BY THE FORMULAS
xMailBody = "Good day," & vbNewLine & vbNewLine & _
"Upon reaching its validation due date, (task_name) is now ready for validation in week (validation_week)." & vbNewLine & vbNewLine & _
"Please arrange a slide and business case to showcase the benefits" & vbNewLine & vbNewLine & _
"Kind Regards,"
On Error Resume Next
With xOutMail
.To = "email1@email"
.CC = ""
.BCC = ""
.Subject = "Validation items are due (TEST PLEASE IGNORE)"
.Body = xMailBody
'.Attachments.Add ActiveWorkbook.FullName
.Display
'or use
'.Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
Private Sub Workbook_Open()
Sheets("Sheet12").Range("U2:U200000").Value = "EMAIL"
End Sub
