I am creating a tracker file for Purchase Orders in which end date in column 'J' is very important.
Column 'J' has following conditional formatting
1. If cell date is in between todays date + 14 days --- YELLOW
2. cell date <= today's date ------------------------- RED
3. cell valus > today + 14 days ---------------------- GREEN
So now when the cell turn Yellow I want the excel should send the mail to the concerned person whose mail id will be mentioned in same row of column 'G'
One more requirement there should be two mails. Reminder 1 & Reminder 2.
I use officer 2010 & mail is outlook 2010 & OS is windows 7.
This file will be on share point. This file may not be opened everyday.
Please reply with the procedure as I am not a programming/ IT person... I may not understand all terms.. please try to simplify the response.
Thanks in advance for all the help.
You'd want a location to mark when an email was sent. I'm assuming you want a worksheet change event for this, which will basically always run when a cell on this specific worksheet is changed. There are other events you could use to fire it off, like the calculate event. You could, if you wanted to, assign this functionality to a button, but then it wouldn't be automatic.
The below code does what you ask. It goes in the worksheet module of the worksheet your data is on. To get to it, right click the sheet tab name and select 'View Code', then paste this there.
EDIT: The locations to mark when an email was sent (btw) were columns K and L, as you'll see them set as constants at the top of the code. You can change those letters to any column you want to house it in. It just puts the current system date in those cells, and that will be checked when the values in column J are checked. If nothing is there it assumes an email hasn't been generated yet and will do so. But if it has a value - any value, it will ignore that row.
Also, I assumed a 'yellow' highlighted value was your first reminder, and a 'red' highlighted value was your second reminder. It uses this as text in the subject and body of the email.
Code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const ReminderOne As String = "K" 'column letter
Const ReminderTwo As String = "L" 'column letter
Dim OL As Object
Dim MailItem As Object
Dim ArrEmail() As Variant
Dim DateCheck As Range
Dim CellCheck As Range
Dim OutlookOpen As Boolean
Dim ArrCount As Long
Dim EmailStep As Long
Dim ColCheck As String
Dim EmailBody As String
Application.EnableEvents = False
Application.ScreenUpdating = False
'Date range to check - column J
Set DateCheck = Me.Range("J2", Me.Cells(Me.Rows.Count, "J").End(xlUp))
'Check cells in range
For Each CellCheck In DateCheck.Cells
'Yellow
If CellCheck.Value <= VBA.Date() + 14 And CellCheck.Value >= VBA.Date() Then
ColCheck = ReminderOne
'Red
ElseIf CellCheck.Value < VBA.Date() Then
ColCheck = ReminderTwo
'Green
Else
GoTo SkipCell
End If
'Check if email was already sent
If Len(Me.Range(ColCheck & CellCheck.Row).Value) > 0 Then GoTo SkipCell
'Add to array
If IsEmpty(ArrEmail) Then
ReDim ArrEmail(1 To 3, 1 To 1)
Else
ArrCount = ArrCount + 1
ReDim Preserve ArrEmail(1 To 3, 1 To ArrCount)
End If
ArrEmail(1, ArrCount) = CellCheck.Offset(0, -3).Value
ArrEmail(2, ArrCount) = ColCheck & CellCheck.Row
ArrEmail(3, ArrCount) = IIf(ColCheck = ReminderOne, 1, 2)
SkipCell:
Next CellCheck
'Check if any reminders need to go out
If ArrCount = 0 Then GoTo NoReminders
'Get Outlook application
On Error Resume Next
Set OL = GetObject(, "Outlook.Application")
OutlookOpen = True
If OL Is Nothing Then
Set OL = CreateObject("Outlook.Application")
OutlookOpen = False
End If
On Error GoTo 0
'Create emails
For EmailStep = 1 To ArrCount
'Create email message
Set MailItem = OL.CreateItem(0)
'To
MailItem.To = ArrEmail(1, EmailStep)
'Subject
MailItem.Subject = VBA.Choose(ArrEmail(3, EmailStep), "First Reminder", "Second Reminder")
'Body
'----------
'Lower case
'EmailBody = "This is your " & VBA.LCase(MailItem.Subject) & "." & vbNewLine & vbNewLine & "Thanks"
'Upper case
EmailBody = "This is your " & VBA.UCase(MailItem.Subject) & "." & vbNewLine & vbNewLine & "Thanks"
MailItem.Body = EmailBody
'Display email
MailItem.Display
'Mark the date when email was generated (will be skipped in future passes)
Me.Range(ArrEmail(2, EmailStep)).Value = VBA.Date()
Next EmailStep
'Close Outlook
If OutlookOpen = False Then
OL.Quit
End If
NoReminders:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
HTH
Status
Not open for further replies.
You have insufficient privileges to reply here.
Related Threads
?
?
?
?
?
Tech Support Guy
9.9M posts
859.7K members
Since 1998
A forum community dedicated to tech experts and enthusiasts. Come join the discussion about articles, computer security, Mac, Microsoft, Linux, hardware, networking, gaming, reviews, accessories, and more!