Solved how do I create Excel Email alert for expiring dates

January 21, 2016 at 11:25:08
Specs: Macintosh
Hello, I have an excel document we use to track the "end" dates of an internet service we offer. What I am trying to do is automate the expiration date of the sheets in excel. When the expiration date for the service of a client is coming up, I would like to receive an email 3 days in advance letting me know it is about to expire. Any help would be great. thank you.

See More: how do I create Excel Email alert for expiring dates

Report •


#1
January 21, 2016 at 12:52:48
You are going to need a Macro to send yourself an E-Mail.

Look here:

http://www.rondebruin.nl/win/sectio...

also, if you search the OFFICE forum with the keywords MACRO and EMAIL
you should get several hits.

MIKE

http://www.skeptic.com/


Report •

#2
January 22, 2016 at 03:31:41
Here is a possible solution.

In my workbook on sheet1 i have

          A              B              C                  D
1      Service     Renewal Date     Days till exp     Status
2      Contract1   25/01/2016          3              Warning
3      Contract2   24/01/2016          2              Warning
4      Contract4   06/02/2016         15              Vallid                 

In column C i have the formula

=B2-Today()

This gives me the days between my renewal date/expiry date and todays date, i use this to determine if the days between today and the renewal/expiry is 3 or below, as per your requirement

in column D i have the formula

=IF(C2="","",IF(C2<=0,"Expired",IF(AND(C2<15,C2>0),"Warning",IF(C2>14,"Valid"))))

This is not neccessay at all but will give you the status as Valid, Expired or Warning.

I use the following macro to generate the email list and then send it.

Dim uRange
Dim lRange
Dim BCell As Range
Dim EmailString As String

Sub GetExpirations()
        
    Set uRange = Sheet1.Range("C2")
    Set lRange = Sheet1.Range("C" & Rows.Count).End(xlUp)
    EmailString = Empty
    
    For Each BCell In Range(uRange, lRange)
        
        If BCell <= 3 Then
                    
            EmailString = EmailString & BCell.Offset(0, -2) & " is due to expire in " & BCell & " days" & vbCrLf
            
        End If
    
    Next BCell
    
    SendMail EmailString
    
End Sub

Sub SendMail(iBody As String)
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String

'If ActiveWorkbook.Saved = True Then

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

    strbody = iBody

    On Error Resume Next
    With OutMail
        .To = "Someone@somewhere.com"
        .CC = ""
        .BCC = ""
        .Subject = "Services due to expire soon"
        .Body = strbody
        'You can add a file like this
        '.Attachments.Add ("")
        .Send   'or use .Display
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing

'End If
End Sub

Notes:

You will need to change the below email address to your email address and subject to whatever you like.

.To = "Someone@somewhere.com"
.Subject = "Services due to expire soon"

Also note, that at pressent you will have to run this macro yourself, however it can be modified to run when you Open or Close the workbook. I think there are ways of adding timers in Excel to periodically run a macro, but iv not done this before (cleanly) so cannot offer a solution for this........

Paste the code into a Module and run from Sub GetExpirations... if your sheet is not called Sheet1 then you will need to change that in the code.

Running the above sent me an email with body

Contract 1 is due to expire in 3 days 
Contract 2 is due to expire in 2 days 

message edited by AlwaysWillingToLearn


Report •

#3
January 22, 2016 at 04:26:32
✔ Best Answer
I have just attempted a timer version, which counts up in seconds until a desired time and then

1) Stops and resets timer
2) Checks for expirations
3) generate and sends the email
4) starts the timer again

In this case the workbook can remain open and the code can run continously, now as i have not tested it thoroughly i cannot gurantee it will work without crashing.. This is something you will have to test.

NOTE: For the timer to work, it needs to enter the seconds into a worksheet iv chosen sheet2.range("B3")

This is very important as without this it cannot check to see how many seconds have lapsed. In the below example it checks for 10 seconds before doing the check. You can change this to wherever duration you want, but for testing purposes make this a minute or so

In sub NextTick() change

If Sheet2.Range("B3").Text >= "00:00:10" Then

to suit

Paste following in module 1

Dim uRange
Dim lRange
Dim BCell As Range
Dim EmailString As String

Public Sub GetExpirations()
        
    Set uRange = Sheet1.Range("C2")
    Set lRange = Sheet1.Range("C" & Rows.Count).End(xlUp)
    EmailString = Empty
    
    For Each BCell In Range(uRange, lRange)
        
        If BCell <= 3 Then
                    
            EmailString = EmailString & BCell.Offset(0, -2) & " is due to expire in " & BCell & " days" & vbCrLf
            
        End If
    
    Next BCell
    
    SendMail EmailString
    
End Sub

Sub SendMail(iBody As String)
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String

'If ActiveWorkbook.Saved = True Then

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

    strbody = iBody

    On Error Resume Next
    With OutMail
        .To = "Someone@somewhere.com"
        .CC = ""
        .BCC = ""
        .Subject = "Services due to expire soon"
        .Body = strbody
        'You can add a file like this
        '.Attachments.Add ("C:\test.txt")
        .Send   'or use .Display
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing

'End If
End Sub


Paste the following in Sheet1

Dim StopTimer           As Boolean
Dim SchdTime            As Date
Dim Etime               As Date
Const OneSec            As Date = 1 / 86400#

Private Sub ResetBtn_Click()
    StopTimer = True
    Etime = 0
    Sheet2.Range("B3").Value = "00:00:00"
End Sub

Private Sub StartBtn_Click()
   StopTimer = False
   SchdTime = Now()
   Sheet2.Range("B3").Value = Format(Etime, "hh:mm:ss")
   Application.OnTime SchdTime + OneSec, "Sheet1.NextTick"
End Sub

Private Sub StopBtn_Click()
    StopTimer = True
    Beep
End Sub

Sub NextTick()
   If StopTimer Then
      'Don't reschedule update
   Else
   
    If Sheet2.Range("B3").Text >= "00:00:10" Then
        Debug.Print Now()
        StopBtn_Click
        ResetBtn_Click
        GetExpirations
        StartBtn_Click
    End If
        
    Sheet2.Range("B3").Value = Format(Etime, "hh:mm:ss")
    SchdTime = SchdTime + OneSec
    Application.OnTime SchdTime, "Sheet1.NextTick"
    Etime = Etime + OneSec
           
   End If
End Sub


Report •

Related Solutions

#4
April 27, 2016 at 19:28:14
Hi. I have tried to run your code in my spread sheet but get an object error. Can you help solve the issue?? I have only basic knowledge of VBA.

Report •

#5
April 27, 2016 at 23:55:54
you need to be more specific about the error message, if you hit debug when the error comes up, it will highlight a line in yellow, you will need to copy the line and paste it here so we can narrow down the probable cause.

Report •

#6
April 28, 2016 at 17:50:16
The error is "Runtime error '424': Object required

Report •

#7
April 29, 2016 at 00:03:40
And did you hit the debug button to identify the offending line of code?

if not, then the only thing I can tell you is that, the code is looking for an object that doesn't seem to exist, this could be a textbox, a command button, an object which is created by the code..... unless provide the line of code where this is failing I will not be able to help, you will need to start a new thread.


Report •


Ask Question