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

[EmmaFos]

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

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

 

[Logit]

Col BM is Col 66 not 59

Your code is looking at column # 59.

 

[EmmaFos]

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]

.
I stripped down your code to the basic. You can add back in what you believe is needed in your particular circumstances :

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]

T

.
I stripped down your code to the basic. You can add back in what you believe is needed in your particular circumstances :

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]

"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.

 

[Abera]

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