kasabel
04-04-2018, 02:47 AM
Hello,
I have been working on a spreadsheet within which I have an auto email on Worksheet_Open which sends out a reminder email based on the date field falling within a certain number of days:
Sub eMail()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList As String
Dim eSubject As String
Dim eBody As String
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Sheets(1).Select
lRow = Cells(Rows.Count, 4).End(xlUp).Row
For i = 2 To lRow
toDate = Replace(Cells(i, 3), ".", "/")
If Left(Cells(i, 5), 4) <> "Mail" And toDate - Date <= 7 Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
toList = Cells(i, 4) 'gets the recipient from col D
eSubject = "PARIS ID: " & Cells(i, 2) & " Due on " & Cells(i, 3) & Cells(i, 6)
eBody = "Dear " & Cells(i, 1) & vbCrLf & vbCrLf & "Please be reminded of the payment detailed in the subject line above and take the required action."
On Error Resume Next
With OutMail
.To = toList
.CC = ""
.BCC = ""
.Subject = eSubject
.Body = eBody
.bodyformat = 1
'.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
Set OutApp = Nothing
Cells(i, 5) = "Mail Sent " & Date + Time 'Marks the row as "email sent in Column A"
End If
Next i
ActiveWorkbook.Save
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Excel.Range
'// It will error if no cells in Col J changed
On Error GoTo Catch
'// Stop any changes made here firing the Event again
Application.EnableEvents = True
'// For each changed cell in Col C
For Each c In Intersect(Range("C:C"), Target)
'// If it now contains something then
If c.Value <> vbNullString Then
'// Blank cell in Col E, same row
c.Offset(, 2).Value = vbNullString
End If
Next
Catch:
'// Make sure event handling is turned on again
'// Critical. Excel stops responding to everything
'// if not reset.
Application.EnableEvents = True
End Sub
This works a treat and puts a mail sent dialogue in the pertinent row where the email was sent in relation to the days falling within parameter I have set.
However, the date cell which prompts the email reminder to be sent changes based on formula contained in another sheet which is based on variables associated with =NOW(). So the formula within the date cell is ='Payment Detail 1718'!Q10.
What I want to be able to do is have code within the workbook which will clear the contents of the mail sent dialogue where this date cell value changes as this will then reset the send email macro and allow for perpetual sending of reminders emails based on new payment dates.
I have searched for and tried a wide variety of clear content code to no avail.
I can email the spreadsheet should anyone be able to help to give a clearer idea of what I am working on.
Also, any suggestions alternative to my approach are very welcome.
Many thanks.
K
I have been working on a spreadsheet within which I have an auto email on Worksheet_Open which sends out a reminder email based on the date field falling within a certain number of days:
Sub eMail()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList As String
Dim eSubject As String
Dim eBody As String
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Sheets(1).Select
lRow = Cells(Rows.Count, 4).End(xlUp).Row
For i = 2 To lRow
toDate = Replace(Cells(i, 3), ".", "/")
If Left(Cells(i, 5), 4) <> "Mail" And toDate - Date <= 7 Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
toList = Cells(i, 4) 'gets the recipient from col D
eSubject = "PARIS ID: " & Cells(i, 2) & " Due on " & Cells(i, 3) & Cells(i, 6)
eBody = "Dear " & Cells(i, 1) & vbCrLf & vbCrLf & "Please be reminded of the payment detailed in the subject line above and take the required action."
On Error Resume Next
With OutMail
.To = toList
.CC = ""
.BCC = ""
.Subject = eSubject
.Body = eBody
.bodyformat = 1
'.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
Set OutApp = Nothing
Cells(i, 5) = "Mail Sent " & Date + Time 'Marks the row as "email sent in Column A"
End If
Next i
ActiveWorkbook.Save
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Excel.Range
'// It will error if no cells in Col J changed
On Error GoTo Catch
'// Stop any changes made here firing the Event again
Application.EnableEvents = True
'// For each changed cell in Col C
For Each c In Intersect(Range("C:C"), Target)
'// If it now contains something then
If c.Value <> vbNullString Then
'// Blank cell in Col E, same row
c.Offset(, 2).Value = vbNullString
End If
Next
Catch:
'// Make sure event handling is turned on again
'// Critical. Excel stops responding to everything
'// if not reset.
Application.EnableEvents = True
End Sub
This works a treat and puts a mail sent dialogue in the pertinent row where the email was sent in relation to the days falling within parameter I have set.
However, the date cell which prompts the email reminder to be sent changes based on formula contained in another sheet which is based on variables associated with =NOW(). So the formula within the date cell is ='Payment Detail 1718'!Q10.
What I want to be able to do is have code within the workbook which will clear the contents of the mail sent dialogue where this date cell value changes as this will then reset the send email macro and allow for perpetual sending of reminders emails based on new payment dates.
I have searched for and tried a wide variety of clear content code to no avail.
I can email the spreadsheet should anyone be able to help to give a clearer idea of what I am working on.
Also, any suggestions alternative to my approach are very welcome.
Many thanks.
K