Send Outlook Mail based on value changes in cell

[elsuji]

Dear Team,


I am updating calibration data's on my excel. In that the last calibration date entered on column G and Next due date will update automatically on Column H which is 90 days time period. In column I update for remaining days. I want to send remainder mail to my customer before 10 days( between 1 to 10 days) of expire the next due date.


For that i had created code for send separate email for each customers. But the mail opening only for the row where i am selecting. First it should check the value on column I where the values between 1 to 10 days and send mail only to that customers.


Once the mail is sent to customer it should print on column J like Mail sent


I attached my file here for your reference.


Kindly do the need full for completing this work.

[macropod]

Cross-posted at: https://www.excelforum.com/excel-programming-vba-macros/1313403-send-outlook-mail-based-on-value-changes-in-cell.html
Please read VBA Express' policy on Cross-Posting in Rule 3: http://www.vbaexpress.com/forum/faq.php?faq=new_faq_item#faq_new_faq_item3

[Logit]

.

Sub emailall2()Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList, CCList As String
Dim eSubject As String
Dim eBody As String
Dim OutApp, OutMail




With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With




Sheets("Sheet1").Select
lRow = Cells(Rows.Count, 2).End(xlUp).Row


Set OutApp = CreateObject("Outlook.Application")


For i = 2 To lRow
If Cells(i, 8).Value = Date + 11 Then '<--- This selects the day to send the email.
Set OutMail = OutApp.CreateItem(0)




toList = Cells(i, 2) 'gets the recipient from col B
CCList = Cells(i, 8) & ", " & Cells(i, 9) & ", " & Cells(i, 10)
eSubject = "You are scheduled for an audit on " & Cells(i, 3) & " at " & Cells(i, 4) & " " & Cells(i, 6)
eBody = "Greetings : " & vbCrLf & vbCrLf & "Scheduled audit is upcoming on the date indicated above."

On Error Resume Next
With OutMail
.To = toList
.CC = CCList
.BCC = ""
.Subject = eSubject
.Body = eBody
.Display ' ********* Creates draft emails. Comment this out when you are ready
'.Send '********** UN-comment this when you are ready to go live
End With

On Error GoTo 0
Set OutMail = Nothing
Cells(i, 12) = "Mail Sent " & Date + Time 'Marks the row as "email sent in Column A"
End If
Next i


Set OutApp = Nothing


ActiveWorkbook.Save




With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
Sheets("Sheet1").Range("A1").Select
End Sub




This is how the workbook is laid out. You can change the code to suit your project based on these field locations.



A
B
C
D
E
F
G
H
I
J
K
L


Site


Email



Date
Time
Address
Time Zone
Area
Area Manager
Region Manager
Director
Subject
Email Sent Verification


5
Site5@email.com
4/23/2020
12:00 pm
123 Happy St
CST
100
areamanager1@email.com
regionm1@email.com
director1@email.com
Leave



10
Site10@email.com
5/24/2018
6:00 am
12 Lonely Ave
EST
100
areamanager2@email.com
regionm2@email.com
director2@email.com
This



12
Site12@email.com
8/4/2017
6:00 m
3 Snippy Dr
CST
100
areamanager3@email.com
regionm1@email.com
director1@email.com
Column



15
Site15@email.com
4/26/2020
12:00 pm
4 Old Farm
EST
200
areamanager4@email.com
regionm1@email.com
director1@email.com
Blank



18
Site18@email.com
8/1/2017
6:00 am
5 Nowhere St
CST
200
areamanager5@email.com
regionm2@email.com
director2@email.com

[elsuji]

Dear Lohit,

Can you please shar ed the link of this thread or if possible pls share the file.

[p45cal]

Cross-posted at: https://www.excelforum.com/excel-programming-vba-macros/1313403-send-outlook-mail-based-on-value-changes-in-cell.html
Please read VBA Express' policy on Cross-Posting in Rule 3: http://www.vbaexpress.com/forum/faq.php?faq=new_faq_item#faq_new_faq_item3

…and at OzGrid.

[elsuji]

I didn't got any reply for my post here. So I posted others also for quick reply

[elsuji]

Dear Logit,

I had modified the code as per my requirement.


Option ExplicitSub emailall2()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList, CCList As String
Dim eSubject As String
Dim eBody As String
Dim OutApp As Object, _
OutMail As Object






With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With


Sheets("Data").Select
lRow = Cells(Rows.Count, 2).End(xlUp).Row


Set OutApp = CreateObject("Outlook.Application")


For i = 2 To lRow
' If Cells(i, 8).Value = Date + 11 Then '<--- This selects the day to send the email.
If Cells(i, 8).Value > 1 And Cells(i, 8).Value < 10 Then
Set OutMail = OutApp.CreateItem(0)

toList = Cells(i, 4) 'gets the recipient from col B
'CCList = Cells(i, 8) & ", " & Cells(i, 9) & ", " & Cells(i, 10)
eSubject = "Calibration remainder for your " & Cells(i, 5) & " Batching Plant "
eBody = "Dear Sir " & vbCrLf & vbCrLf & "Greetings! " & vbCrLf & vbCrLf & _
"Scheduled audit is upcoming on the date indicated above."

On Error Resume Next
With OutMail
.To = toList
.CC = CCList
.BCC = ""
.Subject = eSubject
.Body = eBody
.Display ' ********* Creates draft emails. Comment this out when you are ready
'.Send '********** UN-comment this when you are ready to go live
End With

On Error GoTo 0
Set OutMail = Nothing
Cells(i, 10) = "Mail Sent " & Date + Time 'Marks the row as "email sent in Column A"
End If
Next i


Set OutApp = Nothing




ActiveWorkbook.Save








With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
Sheets("Data").Range("A1").Select
End Sub

But this is not working.

Pls find attached modified file here for your reference.

Kindly check the file and let me know my mistake

[macropod]

I didn't got any reply for my post here. So I posted others also for quick reply
That is no excuse for ignoring the cross-posting rules. You have done this a number of times. Keep it up and you may find your account terminated.

NOTE:
No further help is to be provided until the requirement to abide by the rules is acknowledged and links are provided to all cross-posts.

[p45cal]

I didn't got any reply for my post here. So I posted others also for quick reply2 minutes isn't very long to decide you're not getting any response here.

[elsuji]

Dear Team,

I had changed the code as per my requirement and now the problem is solved.

The modified code is here


Option ExplicitSub Remindermail()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList, CCList As String
Dim eSubject As String
Dim eBody As String
Dim OutApp As Object, _
OutMail As Object
Dim Signature As String
Dim sPath As String
Dim S As String


With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With


Sheets("Data").Select
lRow = Cells(Rows.Count, 4).End(xlUp).Row


Set OutApp = CreateObject("Outlook.Application")


S = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(S, vbDirectory) <> vbNullString Then S = S & Dir$(S & "*.htm") Else S = ""
S = CreateObject("Scripting.FileSystemObject").GetFile(S).OpenAsTextStream(1, -2).ReadAll


For i = 4 To lRow
If Cells(i, 9).Value >= 1 And Cells(i, 9).Value <= 10 And Cells(i, 10).Value = "" Then
Set OutMail = OutApp.CreateItem(0)
toList = Cells(i, 4) 'gets the recipient from col B
'CCList = Cells(i, 8) & ", " & Cells(i, 9) & ", " & Cells(i, 10)
eSubject = "Calibration remainder for your " & Cells(i, 5) & " Batching Plant "
eBody = "<font style=""font-family:Cambria; font-size:12pt;""/font> Dear Sir, <br><br>" _
& "Greetings from " & "<b> SCHWING STETTER! </b><br><br>" _
& "Your " & "<b>" & Worksheets("Data").Cells(i, "E").Value & "</b>" _
& " Batching Plant calibration certificate is going to expire soon ( within " _
& "<b>" & Worksheets("Data").Cells(i, "I").Value & "</b>" & " days ).<br><br>" _
& "Plant Last calibration done date is " & "<b>" & Worksheets("Data").Cells(i, "G").Value & "</b>" _
& " and next due date is " & "<b>" & Worksheets("Data").Cells(i, "H").Value & "</b>" & ".<br><br>" _
& "Kindly do the calibration on time for accurate batching.<br><br>" & S



On Error Resume Next
With OutMail
.To = toList
.CC = CCList
.BCC = ""
.Subject = eSubject
.HTMLBody = eBody
.Display ' ********* Creates draft emails. Comment this out when you are ready
'.Send '********** UN-comment this when you are ready to go live
End With

On Error GoTo 0
Set OutMail = Nothing
Cells(i, 10) = "Reminder Sent on " & Date 'Marks the row as "email sent in Column A"
End If
Next i


Set OutApp = Nothing


ActiveWorkbook.Save


With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
Sheets("Data").Range("A1").Select
End Sub