Send Outlook Mail based on value changes in cell

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.

Cross-posted at: https://www.excelforum.com/excel-pro...s-in-cell.html
Please read VBA Express' policy on Cross-Posting in Rule 3: http://www.vbaexpress.com/forum/faq...._new_faq_item3

.

Code:

---

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

Dear Lohit,

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

Quote:

---

Originally Posted by macropod

Cross-posted at: https://www.excelforum.com/excel-pro...s-in-cell.html
Please read VBA Express' policy on Cross-Posting in Rule 3: http://www.vbaexpress.com/forum/faq...._new_faq_item3

---

…and at OzGrid.

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

Dear Logit,

I had modified the code as per my requirement.

Code:

---

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

Quote:

---

Originally Posted by elsuji

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.

Quote:

---

Originally Posted by elsuji

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

---

2 minutes isn't very long to decide you're not getting any response here.

Dear Team,

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

The modified code is here

Code:

---

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

---