• 0

Solved How Do I Create Excel Email Alert For Expiring Dates

  • 0

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.


1 Answer

  1. 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 = ""
            .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
    End Sub
    Sub NextTick()
       If StopTimer Then
          'Don't reschedule update
        If Sheet2.Range("B3").Text >= "00:00:10" Then
            Debug.Print Now()
        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

    • 0