Solved How Do I Create Excel Email Alert For Expiring Dates

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