Here is a possible solution. You can change the .Display to .Send to automatically send the email without displaying it
The question I have is, what triggers this event to occur?
1) does it trigger when you open the workbook?
2) does it trigger after a specified amount of time (say every few hours)?
3) or is it manually triggered?
anyways, you should be able to modify this to suite.
Dim uRange
Dim lRange
Dim BCell As Range
Dim EmailTo As String
Dim EmailBody As String
Dim EmailSubject As String
Dim EmailString As String
Sub CheckExpiry()
Set uRange = Range("B2")
Set lRange = Range("B" & Rows.Count).End(xlUp)
EmailTo = Empty
EmailSubject = Empty
EmailSubject = Empty
EmailBody = Empty
EmailString = Empty
For Each BCell In Range(uRange, lRange)
If DateDiff("d", Format(Now(), "dd/mm/yyyy"), BCell.Value) <= 0 Then
EmailString = EmailString & BCell.Offset(0, -1) & " " & BCell.Value & vbCrLf
End If
Next BCell
EmailBody = "Hello," & vbCrLf & vbCrLf & "The following employees contract has expired" & vbCrLf & vbCrLf & EmailString
EmailTo = "
Someone@Somewhere.com"
EmailSubject = "Expiry Dates"
SendReminderMail
End Sub
Sub SendReminderMail()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = EmailTo
.CC = ""
.BCC = ""
.Subject = EmailSubject
.Body = EmailBody
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub