Send Email via Outlook based on Excel due Date

[cy sik]

Hi Guys,

I need expert to guide and show me how to send email automatically (via outlook) if the due date is near and already expire. The data available in row by row.

I've 2 emails address in my column D and E respectively. If near due date (2 days before due), will send email to address # 1 and when due, will send email to both address.

Also, I need to show the title of email fix at Column A1 and Body at Column B (same row per email)

Please help.

regards.

 

[daverunt]

Hi,

you didn't say where the due dates were stored so the following has assumed they are in column C and the offsets for the other information is based on C.
Also it only sends mails if it finds the 2 'expected' dates, i.e 2 days prior to being due and actually due.
There is currently nothing to stop it sending the mail again if the macro is run again.

I did 2 other examples here that may be of use.
http://www.mrexcel.com/forum/excel-questions/641177-send-email-based-date.html
http://www.mrexcel.com/forum/excel-questions/658735-help-getting-excel-send-emails-date.html

The code can be placed in ThisWorkbook and run when the workbook is opened using Private Sub Workbook_Open() as shown in the second link.
Until it is working how you want it to though just put it in a normal module and play around.

Sub SendEmail()
           
Dim OutApp As Object
Dim OutMail As Object
Dim EmailSubject As String
Dim EmailSendTo As String
Dim MailBody As String
       
Set rng = Range(Range("C1"), Range("C" & Rows.Count).End(xlUp))
      
For Each cell In rng
If cell.Value <> "" Then

'Get Due Date
    Dte = cell.Value
    
'Get 2 days away by taking 2 days off cell Dte value
    MailDteNear = DateAdd("d", -2, Dte)
    
'Due date is the cell value
    MailDteDue = Dte
    
'Check 2 days away and send to column D address
    If Date = MailDteNear Then
    mail = True
    EmailSendTo = cell.Offset(0, 1).Value
    End If
    
'Check Due and send to column D & E address
    If Date = MailDteDue Then
    mail = True
    EmailSendTo = cell.Offset(0, 1).Value & "; " & cell.Offset(0, 2).Value
    End If
    
 If mail = True Then
    
'Subject string
    EmailSubject = Range("A1").Value 'Cell A1
    
'Mail Body
    MailBody = cell.Offset(0, -1).Value 'Column B
 
'Send Mail
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(o)
        With OutMail
            .Subject = EmailSubject
            .To = EmailSendTo
            '.bcc
            .Body = MailBody
            .Display
            '.send
        End With
 
        Set OutMail = Nothing
        Set OutApp = Nothing
        mail = False
        EmailSendTo = ""
        
 End If
 End If
Next
End Sub

 

[garymilam72]

All,

I have a spreadsheet with completed date, due date, and email. I don't know how to vba code to look through the spreadsheet to see due date and email. I have coded vba to do just one. code is below.

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 = Now() Then Exit Sub
Set xRg = Intersect(Range("B2"), Target)
If xRg Is Nothing Then Exit Sub
If IsNumeric(Target.Value) And Target.Value = Now() 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)
xMailBody = "Sir or Ma'am" & vbNewLine & vbNewLine & _
"Your PSQ form needs to be updated." & vbNewLine & _
"Your last PSQ date is below" & vbNewLine & _
Range("B2") & vbNewLine & _
"" & vbNewLine & _
"v/r Personnel Security"
On Error Resume Next
With xOutMail
.To = Range("C2")
.CC = ""
.BCC = ""
.Subject = "New"
.Body = xMailBody
.Display 'or use .Send
End With

On Error Resume Next

On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing

End Sub