VBA - Email Expired Date and Due Date Approaching +90 Days not working

EmmaFos

New Member
Joined
Oct 25, 2020
Messages
25
Office Version
  1. 2016
Platform
  1. Windows
Hi, I hope someone out there might be able to help, I am trying to write a code that will send an automated email advising Licence Expiry Due in 90 days and will also send an email once the licence has expired.

I'm using "If .Cells(RowNo, "M") <= Date + 90 Then" which works well for expired dates, but when I change it to +90, it sends everything within 90 days and expired pas today. Would really appreciate some help!
VBA Code:
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
    Dim Maildte As Date

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

        For RowNo = 14 To LastRow
            'Change "Date + 30" to suit your timescale
            
            
             If .Cells(RowNo, "BM") <= Date + 90 Then
             Maildte = True
             If Maildte = True 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 = "High Risk Licence Due" 'Change to cell containing subject or type subject
                   Recipient = wsEmail.Cells(RowNo, "E") 'Change to cell containing e-mail address
                   ExpiryDate = wsEmail.Cells(RowNo, "BM") 'Change to cell containing e-mail address
 
                                        
            Msg = "Dear " & Recipient & "," & vbCrLf & vbCrLf
            Msg = Msg & "Your High Risk 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 & "Emma Foster" & vbCrLf
            Msg = Msg & "" & vbCrLf
            Msg = Msg & ""
            
                      
                    .To = Addr
                    .CC = ""
                    .Subject = Subj
                    .Body = Msg
                    .Display
                    .Send
                
                End With
            Set OutApp = Nothing
            Set OutMail = Nothing
            

        End If
        End If
        Next
    End With
End Sub
Thanks very much
 

Some videos you may like

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
but when I change it to +90, it sends everything
Try changing it to Date in stead of +90.
In addition to that, whenever multiple dates consecutively are compared you better start with todays date, something like this ...

VBA Code:
If Expiry < Date Then
    Msg = "Expired"

ElseIf Expiry = Date Then
    Msg = "Expires today"

ElseIf Expiry <= (Date + 90) Then
    Msg = "Due in 90 days or less"

Else
    Msg = "Nothing to worry about..."

End If
 

EmmaFos

New Member
Joined
Oct 25, 2020
Messages
25
Office Version
  1. 2016
Platform
  1. Windows
Try changing it to Date in stead of +90.
In addition to that, whenever multiple dates consecutively are compared you better start with todays date, something like this ...

VBA Code:
If Expiry < Date Then
    Msg = "Expired"

ElseIf Expiry = Date Then
    Msg = "Expires today"

ElseIf Expiry <= (Date + 90) Then
    Msg = "Due in 90 days or less"

Else
    Msg = "Nothing to worry about..."

End If
Thanks very much for your reply, I appreciate your help. I've changed my code to a similar format and it is now emailing every row, regardless of date. Would you have have any other suggestions please? My new code is below. Thank you so very much!
VBA Code:
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("Name")
    
    With wsEmail
        LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row

        For RowNo = 14 To LastRow
            'Change "Date + 90" to suit your timescale
            
           If Expiry < Date Then
                     Msg = "Expired"
                    
           ElseIf Expiry < (Date + 90) Then
                     Msg = "Due to Expire"
                    
           End If
                                  
                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 = "High Risk Licence Due" 'Change to cell containing subject or type subject
                   Recipient = wsEmail.Cells(RowNo, "E") 'Change to cell containing e-mail address
                   Expiry = wsEmail.Cells(RowNo, "BM") 'Change to cell containing e-mail address
                                        
            Msg = "Dear " & Recipient & "," & vbCrLf & vbCrLf
            Msg = Msg & "Your High Risk Licence is due to expire on: " & vbCrLf & vbCrLf
            Msg = Msg & Expiry & 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 & ""
            
                      
                    .To = Addr
                    .CC = ""
                    .Subject = Subj
                    .Body = Msg
                    .Display
                    .Send
                    
          
             End With
            Set OutApp = Nothing
            Set OutMail = Nothing
                        
       Next
    End With
End Sub
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
So you need one procedure that handles both conditions: already expired and due to expire. Am I right?
 

EmmaFos

New Member
Joined
Oct 25, 2020
Messages
25
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

So you need one procedure that handles both conditions: already expired and due to expire. Am I right?
That's exactly right, I am new and learning as I go - so I apologise if my questions are a little amateur! Thanks
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
No worries, I'm already tinkering with your code ...
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

Although I have not been able to test it, I think the code below should work. If not, let me know.

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

    Dim Recipient       As String
    Dim ExpiryDate      As String
    Dim bMailRequired   As Boolean
    
    On Error Resume Next
    Set OutApp = GetObject("Outlook.Application")
    On Error GoTo 0
    If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")

    Set wsEmail = ThisWorkbook.Sheets("Structural")
    With wsEmail
        LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
        
        For RowNo = 14 To LastRow
            
            Recipient = .Cells(RowNo, "E")
            ExpiryDate = .Cells(RowNo, "BM")

            If .Cells(RowNo, "BM") < Date Then
                ' licence has already expired
                bMailRequired = True
                Subj = "High Risk Licence has expired"
                Msg = "Dear " & Recipient & "," & vbCrLf & vbCrLf
                Msg = Msg & "Your High Risk Licence has expired on: " & vbCrLf & vbCrLf
                Msg = Msg & ExpiryDate & vbCrLf & vbCrLf
                Msg = Msg & "Please schedule this training with management or the training coordinator." & vbCrLf & vbCrLf

            ElseIf .Cells(RowNo, "BM") <= (Date + 90) Then
                ' licence is due to expire
                bMailRequired = True
                Subj = "High Risk Licence Due"
                Msg = "Dear " & Recipient & "," & vbCrLf & vbCrLf
                Msg = Msg & "Your High Risk 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

            Else
                'nothing to send
                bMailRequired = False
                
            End If
            
            If bMailRequired Then
                Msg = Msg & "Thank you," & vbCrLf & vbCrLf & _
                            "Emma Foster" & vbCrLf
            
                Addr = .Cells(RowNo, "F")
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    .To = Addr
                    .CC = ""
                    .Subject = Subj
                    .Body = Msg
                    .Display
                    .Send
                End With
                DoEvents
            End If
        
        Next RowNo
    End With
    
    Set OutApp = Nothing
    Set OutMail = Nothing
    Set wsEmail = Nothing
End Sub
 
Solution

EmmaFos

New Member
Joined
Oct 25, 2020
Messages
25
Office Version
  1. 2016
Platform
  1. Windows
Sub SendEMail() Dim Addr As String, Subj As String Dim Msg As String Dim LastRow As Long, RowNo As Long Dim wsEmail As Worksheet Dim OutApp As Object Dim OutMail As Object Dim Recipient As String Dim ExpiryDate As String Dim bMailRequired As Boolean On Error Resume Next Set OutApp = GetObject("Outlook.Application") On Error GoTo 0 If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application") Set wsEmail = ThisWorkbook.Sheets("Structural") With wsEmail LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row For RowNo = 14 To LastRow Recipient = .Cells(RowNo, "E") ExpiryDate = .Cells(RowNo, "BM") If .Cells(RowNo, "BM") < Date Then ' licence has already expired bMailRequired = True Subj = "High Risk Licence has expired" Msg = "Dear " & Recipient & "," & vbCrLf & vbCrLf Msg = Msg & "Your High Risk Licence has expired on: " & vbCrLf & vbCrLf Msg = Msg & ExpiryDate & vbCrLf & vbCrLf Msg = Msg & "Please schedule this training with management or the training coordinator." & vbCrLf & vbCrLf ElseIf .Cells(RowNo, "BM") <= (Date + 90) Then ' licence is due to expire bMailRequired = True Subj = "High Risk Licence Due" Msg = "Dear " & Recipient & "," & vbCrLf & vbCrLf Msg = Msg & "Your High Risk 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 Else 'nothing to send bMailRequired = False End If If bMailRequired Then Msg = Msg & "Thank you," & vbCrLf & vbCrLf & _ "Emma Foster" & vbCrLf Addr = .Cells(RowNo, "F") Set OutMail = OutApp.CreateItem(0) With OutMail .To = Addr .CC = "" .Subject = Subj .Body = Msg .Display .Send End With DoEvents End If Next RowNo End With Set OutApp = Nothing Set OutMail = Nothing Set wsEmail = Nothing End Sub
You're a gem! Works perfectly, thank you so much! I'm now going to try to add in the headings and cell ranges into the email body, wish me luck!
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
You are welcome and thanks for letting me know.

I'm now going to try to add in the headings and cell ranges into the email body, wish me luck!
🤞👊
 

Watch MrExcel Video

Forum statistics

Threads
1,119,084
Messages
5,576,022
Members
412,694
Latest member
Deaf1Too
Top