1. Computer problem? Tech Support Guy is completely free -- paid for by advertisers and donations. Click here to join today! If you're new to Tech Support Guy, we highly recommend that you visit our Guide for New Members.

Auto mail from Excel to Outlook based on date in cell

Discussion in 'Business Applications' started by abhi1981_i, Nov 27, 2013.

Thread Status:
Not open for further replies.
  1. abhi1981_i

    abhi1981_i Thread Starter

    Joined:
    Nov 27, 2013
    Messages:
    2
    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.
     
  2. Zack Barresse

    Zack Barresse

    Joined:
    Jul 25, 2004
    Messages:
    5,452
    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
     
As Seen On
As Seen On...

Welcome to Tech Support Guy!

Are you looking for the solution to your computer problem? Join our site today to ask your question. This site is completely free -- paid for by advertisers and donations.

If you're not already familiar with forums, watch our Welcome Guide to get started.

Join over 733,556 other people just like you!

Loading...
Thread Status:
Not open for further replies.

Short URL to this thread: https://techguy.org/1114066

  1. This site uses cookies to help personalise content, tailor your experience and to keep you logged in if you register.
    By continuing to use this site, you are consenting to our use of cookies.
    Dismiss Notice