Private Sub Workbook_Open()
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 rowDate As Long, today As Long
Dim I As Long
On Error Resume Next
Set xRgDate = Range("A1:A2", Range("A" & Rows.Count).End(xlUp)) ' Email Address
xLastRow = xRgDate.Rows.Count
Set xRgDate = xRgDate(1)
Set xRgSend = Cells(xRgDate.Row, "B") ' Reminder Content
Set xRgText = Cells(xRgDate.Row, "C") ' Completion Deadline Date
Set xOutApp = CreateObject("Outlook.Application")
For I = 1 To xLastRow
xRgDateVal = xRgDate.Offset(I - 1).Value
today = Date
rowDate = xRgDate.Offset(I - 1).Value
If rowDate - today <= 30 And rowDate - today > 0 Then
xRgSendVal = xRgSend.Offset(I - 1).Value
xMailSubject = xRgText.Offset(I - 1).Value & " on " & xRgDateVal
vbCrLf = "<br><br>"
xMailBody = "<HTML><BODY>"
xMailBody = xMailBody & "Dear " & xRgSendVal & vbCrLf ' Greeting
xMailBody = xMailBody & "Text : " & xRgText.Offset(I - 1).Value & vbCrLf
xMailBody = xMailBody & "</BODY></HTML>"
Set xMailItem = xOutApp.CreateItem(0)
With xMailItem
.Subject = xMailSubject
.To = xRgSendVal
.HTMLBody = xMailBody
.Display
'.Send
End With
Set xMailItem = Nothing
End If
Next
Set xOutApp = Nothing
End Sub
