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

Rajesh N

New Member
Joined
Apr 8, 2021
Messages
1
Office Version
  1. 2019
Platform
  1. Windows
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
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.

Forum statistics

Threads
1,141,715
Messages
5,708,038
Members
421,540
Latest member
quocbinh

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
Top