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

E

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
 

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
Sort by date Sort by votes
EmmaFos said:
but when I change it to +90, it sends everything
Click to expand...
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
 
Upvote 0
GWteB said:
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
Click to expand...
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
 
Upvote 0
So you need one procedure that handles both conditions: already expired and due to expire. Am I right?
 
Upvote 0
GWteB said:
So you need one procedure that handles both conditions: already expired and due to expire. Am I right?
Click to expand...
That's exactly right, I am new and learning as I go - so I apologise if my questions are a little amateur! Thanks
 
Upvote 0
No worries, I'm already tinkering with your code ...
 
Upvote 0
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
 
Upvote 0
Solution
GWteB said:
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
Click to expand...
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!
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
Outlook Email not opening from Excel Macro. Was previously working fine for months
Replies
1
Views
731
Domenic
D
melodramatic
  • Question Question
VBA Send Outlook email, Save email to file folder
Replies
3
Views
2K
melodramatic
melodramatic
B
  • Solved
VBA to email recipient if column cells contain value
Replies
6
Views
475
bh24524
B
A
  • Solved
3 way use button to run macro
Replies
2
Views
353
Aleytha
A
H
  • Question Question
Macro to email Report
Replies
2
Views
529
howard
H

Forum statistics

Threads
1,223,247
Messages
6,171,004
Members
452,374
Latest member
keccles

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top