Auto send email when dependant on date in cell

micko1

Board Regular
Joined
Feb 10, 2010
Messages
80
I have a workbook that has compliance dates in columns "F","G" and "H" from row 7. What I need is when the date in either column comes within 30 days to auto send an email, address in column "A", recipients name in column "B". and then place todays date in column 'P". ALso need to send a follow up email when either date comes within 7days and then place todays date in column "Q". If there is a date in column "P" then don't send email. If there is a date in column "Q" then don't send follow up. Can this be done without the users intervention and each time the workbook is opened.
Thanks in advance for any assistance.

Mick
 

Some videos you may like

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.

micko1

Board Regular
Joined
Feb 10, 2010
Messages
80
Thanks for the assist but I do not know enough about coding to adapt this to my requirements. Tried playing around with it and other code I managed to source but I just have to admit when I am beat. Not sure if you can give me more to work with.
Thanks
Mick
 

micko1

Board Regular
Joined
Feb 10, 2010
Messages
80
This is what I have so far. Macro is placing date in correct cell and sending the email. In column "A" I have the email addresses ("TO") and in column "B" I have the ("recipient"). I am not sure how to reference these cells in the email code. Hope you can help.

Mick

Sub Macro1()
Dim rngCell As Range
Dim rngMyDataSet As Range
Dim Rng As Range
Application.ScreenUpdating = False
'Assumes the due dates are in Column F. Change if required.
With ActiveSheet
If .FilterMode Then .ShowAllData

Set Rng = .Range("A7", .Cells(.Rows.Count, 1).End(xlUp))
End With


For Each rngCell In Rng
If rngCell.Offset(0, 6) > 0 Then Exit Sub

If rngCell.Offset(0, 5) > Evaluate("Today() +7") And _
rngCell.Offset(0, 5).Value <= Evaluate("Today() +30") Then
rngCell.Offset(0, 6).Value = Date
Call Mail_small_Text_Outlook
End If

Next rngCell
Application.ScreenUpdating = True
End Sub



Sub Mail_small_Text_Outlook()
'Working in Office 2000-2010
Dim OutApp As Object
Dim OutMail As Object
Dim EmailSubject As String
Dim EmailSendTo As String
Dim MailBody As String
Dim c As Long
Dim r As Long
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "According to our records your " & Range("F6").Value & " is due for renewal."

On Error Resume Next
With OutMail
.To = "testemail@test.com.au"
.CC = "testemail1@test2.com.au"
.BCC = ""
.Subject = "Request for Information"
.Body = strbody

.Display
End With
On Error GoTo 0
Set OutMail = Nothing
 

daverunt

Well-known Member
Joined
Jul 9, 2009
Messages
1,886
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

Hi,

You are using the code e.g rngCell.Offset(0, 5) already to check various values in the columns you should use this to get the email addresses too.

I think TO = rngCell.Value
and Recipient = rngCell.Offset(0, 1).Value
 
Last edited:

micko1

Board Regular
Joined
Feb 10, 2010
Messages
80
Thanks for the assist, not sure if this is the best way but I combined both macros into one and all appears to be working so far.
Still got some way to go, but so far it is doing what I want.
Thanks again I appreciate the help. I am sure there will be another stumbling block just around the corner. I would appreciate your feedback on the code I have so far.

Mick

Sub Macro1()
Dim rngCell As Range
Dim rngMyDataSet As Range
Dim Rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim EmailSubject As String
Dim EmailSendTo As String
Dim MailBody As String
Dim EmailRecipient As String
Dim Signature As String
Application.ScreenUpdating = False
With ActiveSheet
If .FilterMode Then .ShowAllData
Set Rng = .Range("A7", .Cells(.Rows.Count, 1).End(xlUp))
End With
For Each rngCell In Rng
If rngCell.Offset(0, 6) > 0 Then

ElseIf rngCell.Offset(0, 5) > Evaluate("Today() +7") And _
rngCell.Offset(0, 5).Value <= Evaluate("Today() +30") Then
rngCell.Offset(0, 6).Value = Date

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

strbody = "Dear " & rngCell.Offset(0, 1).Value & vbNewLine & "According to our records your " & Range("F6").Value & " is due for renewal on " & rngCell.Offset(0, 5).Value & vbNewLine & _
"Could you please ensure you send us a copy of your renewal prior to this date."
EmailSendTo = rngCell.Offset(0, 0).Value
EmailSubject = Sheets("sheet1").Range("F6").Value
EmailRecipient = rngCell.Offset(0, 1).Value
Signature = "C:\Documents and Settings\" & Environ("rmm") & _
"\Application Data\Microsoft\Signatures\rm.htm"
On Error Resume Next
With OutMail
.To = EmailSendTo
.CC = "admin@.com.au"
.BCC = ""
.Subject = EmailSubject
.Body = strbody
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing

End If

Next rngCell
Application.ScreenUpdating = True
End Sub
 

daverunt

Well-known Member
Joined
Jul 9, 2009
Messages
1,886
Office Version
  1. 2013
Platform
  1. Windows
Hi Mick,

If the code works then don't worry about it. There are so many ways to skin a cat. I can't see anything that I wouldn't use. Maybe someone else might post a suggestion.

However you could place your code between code tags in your posts though. Looks neater and complies with the posting rules and is easier to read : )

http://www.mrexcel.com/forum/misc.php?do=bbcode#code
E.G
Code:
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


Have a look at this post. It is a workbook open event that fires off a mail if a specific date is found. The Code is pasted in the 'ThisWorkbook' section of the VBA project rather than a module.

http://www.mrexcel.com/forum/showthread.php?t=512138
 

Watch MrExcel Video

Forum statistics

Threads
1,122,371
Messages
5,595,782
Members
414,020
Latest member
Meghdad

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top