VBA Sending emails when due date is approaching or expired, including row extract

EmmaFos

New Member
Joined
Oct 25, 2020
Messages
12
Office Version
  1. 2016
Platform
  1. Windows
Hi, I'm looking for some advice on my code below - I'm new to VBA and have a scenario where I would like to email clients when their licence is due to expire in 90 days and also if it has expired. I found this code on another thread which sends the email however, it's not picking up the 90 day criteria. I'm also looking to see if it's possible to add an extract of the row range into the email body?
Column "E" is the person's name, "F' is the email address and column "BM" is the expiry date. I would very much appreciate any help. Thanks

VBA Code:
Sub SendEmail()
Dim OutlookApp As Outlook.Application
Dim MItem As Outlook.MailItem
Dim cell As Range
Dim Subj As String
Dim EmailAddr As String
Dim Recipient As String

Set OutApp = CreateObject("Outlook.Application")

For Each cell In Columns("F").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "*@*" Then
If cell.Value <> "" Then

Subj = "Licence Due"
Recipient = cell.Offset(0, -1).Value
EmailAddr = cell.Value


ExpiryDate = Format(cell.Offset(0, 59).Value, "dd/mm/yy")
MailDte = DateAdd("d", -90, ExpiryDate)
If Date >= MailDte And cell.Offset(0, 59).Interior.ColorIndex = xlNone Then
Mail = True
Else
If Mail = True Then
cell.Offset(0, 59).Interior.ColorIndex = 36
End If

Msg = "Dear " & Recipient & "," & vbCrLf & vbCrLf
Msg = Msg & "Your Licence is due to expire on: " & vbCrLf & vbCrLf
Msg = Msg & ExpiryDate & vbCrLf & vbCrLf
Msg = Msg & "Please schedule this training with management or the training coordinator." & vbCrLf & vbCrLf
Msg = Msg & "Thank you," & vbCrLf & vbCrLf
Msg = Msg & "NAME" & vbCrLf
Msg = Msg & "" & vbCrLf
Msg = Msg & ""

Set MItem = OutApp.CreateItem(olMailItem)
With MItem
.To = EmailAddr
.Subject = Subj
.body = Msg
.Display
.Send
End With
End If
End If
End If
Next
End Sub
 

Some videos you may like

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).

Logit

Well-known Member
Joined
Aug 31, 2016
Messages
3,697
Col BM is Col 66 not 59

Your code is looking at column # 59.
 

EmmaFos

New Member
Joined
Oct 25, 2020
Messages
12
Office Version
  1. 2016
Platform
  1. Windows
Col BM is Col 66 not 59

Your code is looking at column # 59.
Thanks very much for getting back to me, column BM is 59 from the cell value and it is returning the correct licence expiry column in the email, the issue I have is that its emailing every row's expiry date, not just those within 90 days of today. Any suggestions?
Thanks so very much
 

Logit

Well-known Member
Joined
Aug 31, 2016
Messages
3,697
.
I stripped down your code to the basic. You can add back in what you believe is needed in your particular circumstances :

VBA Code:
Option Explicit

Sub SendEMail()
    Dim Addr As String, Subj As String
    Dim Msg As String
    Dim LastRow As Long, NextRow As Long, RowNo As Long
    Dim wsEmail As Worksheet
    Dim OutApp As Object
    Dim OutMail As Object

    Set wsEmail = ThisWorkbook.Sheets("Sheet1")
    
    With wsEmail
        LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row

        For RowNo = 2 To LastRow
            'Change "Date + 30" to suit your timescale
            
            If .Cells(RowNo, "BM") <= Date + 90 Then
                
                On Error Resume Next
                Set OutApp = GetObject("Outlook.Application")
                    On Error GoTo 0
                    If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
                    Do: Loop Until Not OutApp Is Nothing
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    Addr = wsEmail.Cells(RowNo, "F") 'Change to cell containing e-mail address
                    Subj = wsEmail.Cells(RowNo, "I") 'Change to cell containing subject or type subject
                                        
                    Msg = "Good Day" & "," & vbCrLf & vbCrLf _
                        & "This is an automated e-mail to let you know that document" & vbCrLf _
                        & wsEmail.Cells(RowNo, "D") & vbCrLf _
                        & "That was issued for " & wsEmail.Cells(RowNo, "E") & " is due on " & wsEmail.Cells(RowNo, "G") & "." & vbCrLf & vbCrLf _
                        & "Many Thanks, " & vbCrLf & vbCrLf & "AutoMech"
                        
                    .To = Addr
                    .CC = ""
                    .Subject = Subj
                    .Body = Msg
                    .Display

                End With
            Set OutApp = Nothing
            Set OutMail = Nothing
            
        End If
        Next
    End With
End Sub
 

EmmaFos

New Member
Joined
Oct 25, 2020
Messages
12
Office Version
  1. 2016
Platform
  1. Windows
T
.
I stripped down your code to the basic. You can add back in what you believe is needed in your particular circumstances :

VBA Code:
Option Explicit

Sub SendEMail()
    Dim Addr As String, Subj As String
    Dim Msg As String
    Dim LastRow As Long, NextRow As Long, RowNo As Long
    Dim wsEmail As Worksheet
    Dim OutApp As Object
    Dim OutMail As Object

    Set wsEmail = ThisWorkbook.Sheets("Sheet1")
   
    With wsEmail
        LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row

        For RowNo = 2 To LastRow
            'Change "Date + 30" to suit your timescale
           
            If .Cells(RowNo, "BM") <= Date + 90 Then
               
                On Error Resume Next
                Set OutApp = GetObject("Outlook.Application")
                    On Error GoTo 0
                    If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
                    Do: Loop Until Not OutApp Is Nothing
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    Addr = wsEmail.Cells(RowNo, "F") 'Change to cell containing e-mail address
                    Subj = wsEmail.Cells(RowNo, "I") 'Change to cell containing subject or type subject
                                       
                    Msg = "Good Day" & "," & vbCrLf & vbCrLf _
                        & "This is an automated e-mail to let you know that document" & vbCrLf _
                        & wsEmail.Cells(RowNo, "D") & vbCrLf _
                        & "That was issued for " & wsEmail.Cells(RowNo, "E") & " is due on " & wsEmail.Cells(RowNo, "G") & "." & vbCrLf & vbCrLf _
                        & "Many Thanks, " & vbCrLf & vbCrLf & "AutoMech"
                       
                    .To = Addr
                    .CC = ""
                    .Subject = Subj
                    .Body = Msg
                    .Display

                End With
            Set OutApp = Nothing
            Set OutMail = Nothing
           
        End If
        Next
    End With
End Sub
Thanks, this is definitely simplified my code! The " If .Cells(RowNo, "BM") <= Date + 90 Then" line is still producing emails for every row, not just those due to expire within 90 days. Also, I would like to imbed a cell range into the email body, ie the heading and cell ranges in the respective row for the approaching. Would you have an suggestions, really appreciate your help!
 

Logit

Well-known Member
Joined
Aug 31, 2016
Messages
3,697
"is still producing emails for every row"

Not certain what is happening there but the code works as desired here for the 90 days period or less.
 

Watch MrExcel Video

Forum statistics

Threads
1,112,799
Messages
5,542,574
Members
410,560
Latest member
1ndependent
Top