Automated emails based on Expiry date of different products into one mail

[Rajesh N]

Hi All,

I need help creating a code that send an automated email based on the expiry date of different products. The main problem I am having is including all the expired products into one email, as opposed to multiple emails. The excel sheet that includes expiration date in column "C", the name of the products in column "B", has a product batch number in column D and recipient email id in column A.

Here is the code I have so far:

Public Sub CheckAndSendMail()
Dim xRgDate As Range
Dim xRgSend As Range
Dim xRgText As Range
Dim xRgDone As Range
Dim xOutApp As Object
Dim xMailItem As Object
Dim xLastRow As Long
Dim vbCrLf As String
Dim xMailBody As String
Dim xRgDateVal As String
Dim xRgSendVal As String
Dim xMailSubject As String
Dim xStrRang As String
Dim i As Long
On Error Resume Next
'Please specify the due date range
xStrRang = "C2:C100"
Set xRgDate = Range(xStrRang)
'Please specify the recipients email address range
xStrRang = "A2:A100"
Set xRgSend = Range(xStrRang)
'Specify the range with reminded content in your email
xStrRang = "B2:B100"
Set xRgText = Range(xStrRang)
'Specify the range with reminded Lot in your email
xStrRang = "D2:D100"
Set xRgLot = Range(xStrRang)

xLastRow = xRgDate.Rows.Count
Set xRgDate = xRgDate(1)
Set xRgSend = xRgSend(1)
Set xRgText = xRgText(1)
Set xRgLot = xRgLot(1)
Set xOutApp = CreateObject("Outlook.Application")
For i = 1 To xLastRow
xRgDateVal = ""
xRgDateVal = xRgDate.Offset(i - 1).Value
If xRgDateVal <> "" Then
If CDate(xRgDateVal) - Date <= 7 And CDate(xRgDateVal) - Date > 0 Then
xRgSendVal = xRgSend.Offset(i - 1).Value
xMailSubject = xRgText.Offset(i - 1).Value
vbCrLf = "<br><br>"


xMailBody = ""
xMailBody = xMailBody & "Dear All, " & vbCrLf
xMailBody = xMailBody & "Please check and arrange new Material for the following, " & vbCrLf
xMailBody = xMailBody & "Name : " & xRgText.Offset(i - 1).Value & vbCrLf & xRgLot.Offset(i - 1).Value & vbCrLf
xMailBody = xMailBody & " Expire on : " & xRgDateVal
xMailBody = xMailBody & ""
Set xMailItem = xOutApp.CreateItem(0)
With xMailItem
.Display
.Subject = xMailSubject
.to = xRgSendVal
.CC = " "
.HTMLBody = xMailBody & .HTMLBody

'.send
End With
Set xMailItem = Nothing
End If
End If
Next
Set xOutApp = Nothing
End Sub