Sep 13 2022 08:04 AM
I need to insert code into my existing macro that will send email based on two things: 1) If Cell P (Email Sent) has a date in it, don't send any email; 2) Send only email if Cell O (Review Date) is within 120 days prior to the date in Cell O. Below is the code I have so far. I've attached the spreadsheet also. Can anyone help me with this? Thanks so much.
Sub Button1_Click()
Dim rngCell As Range
Dim Rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim strBody As String
Dim EmailSubject As String
Dim SendToMail As String
Dim r As Long
With ActiveSheet
If .FilterMode Then .ShowAllData
End With
Set OutApp = CreateObject("Outlook.Application")
Set Rng = Range("AH5", Cells(Rows.Count, "AH").End(xlUp))
For Each rngCell In Rng
r = rngCell.Row
Range("P" & r).Value = Date
Set OutMail = OutApp.CreateItem(0)
strBody = "According to my records, your " & Range("A" & r).Value & _
" contract is due for review. This contract expires " & Range("Q" & r).Value & _
". It is important you review this contract ASAP and email me " & _
"with any changes that are made. If it is renewed or rolled over, please fill out the " & _
"Contract Cover Sheet which can be found in the Everyone folder " & _
"and send me the Contract Cover Sheet along with the new original contract."
SendToMail = Range("AH" & r).Value
EmailSubject = Range("A" & r).Value
On Error Resume Next
With OutMail
.To = SendToMail
.CC = "email address removed for privacy reasons"
.BCC = ""
.Subject = EmailSubject
.Body = strBody
.Display ' You can use .Send
End With
Application.ScreenUpdating = False
'End If
Next rngCell
Application.ScreenUpdating = True
End Sub
Sep 13 2022 01:49 PM
"Send only email if Cell O (Review Date) is within 120 days prior to the date in Cell O" cannot be correct. What should it be?
Sep 13 2022 01:56 PM
Sep 13 2022 01:57 PM - edited Sep 13 2022 01:58 PM
You write "where the Expiration Date in Column Q is a max of 120 days prior to that date."
What is that date? The date in column O?
Sep 13 2022 02:02 PM
Try this:
Sub Button1_Click()
Dim rngCell As Range
Dim Rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim strBody As String
Dim EmailSubject As String
Dim SendToMail As String
Dim r As Long
Application.ScreenUpdating = False
With ActiveSheet
If .FilterMode Then .ShowAllData
End With
Set OutApp = CreateObject("Outlook.Application")
Set Rng = Range("AH5", Cells(Rows.Count, "AH").End(xlUp))
For Each rngCell In Rng
r = rngCell.Row
If Range("P" & r).Value = "" And Range("Q" & r).Value <> "" And Range("O" & r).Value >= Range("Q" & r).Value - 120 Then
Range("P" & r).Value = Date
Set OutMail = OutApp.CreateItem(0)
strBody = "According to my records, your " & Range("A" & r).Value & _
" contract is due for review. This contract expires " & Range("Q" & r).Value & _
". It is important you review this contract ASAP and email me " & _
"with any changes that are made. If it is renewed or rolled over, please fill out the " & _
"Contract Cover Sheet which can be found in the Everyone folder " & _
"and send me the Contract Cover Sheet along with the new original contract."
SendToMail = Range("AH" & r).Value
EmailSubject = Range("A" & r).Value
On Error Resume Next
With OutMail
.To = SendToMail
.CC = "email address removed for privacy reasons"
.BCC = ""
.Subject = EmailSubject
.Body = strBody
.Display ' You can use .Send
End With
End If
Next rngCell
Application.ScreenUpdating = True
End Sub
Sep 13 2022 02:02 PM
Sep 13 2022 02:07 PM
Sep 13 2022 02:25 PM
SolutionI was misled by your description. Change the line
If Range("P" & r).Value = "" And Range("Q" & r).Value <> "" And Range("O" & r).Value >= Range("Q" & r).Value - 120 Then
to
If Range("P" & r).Value = "" And Range("Q" & r).Value <> "" And Range("O" & r).Value <= Date Then
Sep 14 2022 05:51 AM
Sep 13 2022 02:25 PM
SolutionI was misled by your description. Change the line
If Range("P" & r).Value = "" And Range("Q" & r).Value <> "" And Range("O" & r).Value >= Range("Q" & r).Value - 120 Then
to
If Range("P" & r).Value = "" And Range("Q" & r).Value <> "" And Range("O" & r).Value <= Date Then