Tech Support Guy banner
Status
Not open for further replies.

Auto mail from Excel to Outlook based on date in cell

5K views 1 reply 2 participants last post by  Zack Barresse 
#1 ·
Dear All,

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.
 
See less See more
#2 ·
Hi there, welcome to the board!

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.
Top