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

EmmaFos

New Member
Joined
Oct 25, 2020
Messages
25
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
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Col BM is Col 66 not 59

Your code is looking at column # 59.
 
Upvote 0
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
 
Upvote 0
.
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
 
Upvote 0
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!
 
Upvote 0
"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.
 
Upvote 0
dear Logit

I get this VBA usefull for me and it works however , what I need is if many peopepl in the list of the excel due date reached and when I run the VBA it asks me in the outlook to press the send button for every one in the list it is time taking so is there any way to send every email when i run the code without my intervention to press the send button

1663660272760.png
 
Upvote 0

Forum statistics

Threads
1,223,236
Messages
6,170,915
Members
452,366
Latest member
TePunaBloke

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