How to make a day timer

Tech Mgr

I've modified (/added to) Don's tutorial file to create a version which will accept a number of days too (they're entered in cell B4, with hh:mm:ss in C4). 

It's not foolproof (and comes with no guarantees) but once you set a time and press Start Timer, it should display the end time (in B2 and C2) and start a second-by-second countdown in green digits. Don't change the font colour though since that used to determine how the digits flash once the timer has finished (alternating yellow and red). The modified code is below (with comments), including a new macro Start_Timer which runs when the Start Timer button is clicked (before the timer macro runs):

Public interval As Date
Sub Start_Timer()
Dim TimeEnd As Date

TimeEnd = Now + Range("B4").Value + Range("C4").Value ' work out end time
Range("B2") = Int(TimeEnd) ' get end date
Range("C2") = TimeEnd - Range("B2") + TimeValue("00:00:01") ' get end time
Timer 'start timer

End Sub
Sub Timer()
' TeachExcel.com

    ' Check if the timer is finished and skip countdown if it is
    If Range("B4").Value + Range("C4").Value = 0 Then
        With Range("B4:C4")
            If .Font.Color <> vbRed Then
                .Font.Color = vbRed
                Else
                .Font.Color = vbYellow
            End If
        End With
        GoTo OneSec
    End If


    ' Check if a day has elasped
    If Range("B4").Value > 0 And Range("C4") = 0 Then Range("B4").Value = Range("B4").Value - 1

    If Range("C4") = 0 Then
        Range("C4").Value = TimeValue("23:59:59")
        Else
        ' Remove 1 second from the timer
        Range("C4").Value = Range("C4").Value - TimeValue("00:00:01")
    End If
OneSec:
    ' Set when the macro should run again - should be the same time value
    ' as the previous line.
    interval = Now + TimeValue("00:00:01")

    ' Make this macro run again in 1 second
    Application.OnTime interval, "timer"

End Sub
Sub stop_timer()
' TeachExcel.com
    On Error Resume Next 'in case timer isn't running
    ' Stop the timer macro from running
    Application.OnTime EarliestTime:=interval, Procedure:="Timer", Schedule:=False

End Sub
Sub reset_timer()
' TeachExcel.com

    ' Default time for the timer
    Range("B4").Value = 0
    Range("C4").Value = "00:01:00"
    Range("B4:C4").Font.Color = vbGreen
    Range("B2:C2") = ""
End Sub

I've also added some workbook event macros so (hopefully) you can set a timer running for more than a day and quit or turn off your computer in the meantime (provided you save it). When it's re-opened, it should continue the countdown. The code for those covers what happens when you open and close the workbook and is as follows:

Private Sub Workbook_Open()
Dim TimeLeft As Date

' Check if timer was set
If Range("B2") = "" And Range("C2") = "" Then Exit Sub

'Has target been reached?
If (Range("B2") + Range("C2")) <= Now Then
    'if so, zero timer and start (to flashing)
    Range("B4") = 0
    Range("C4") = TimeValue("00:00:00")
    Timer
    Exit Sub
    'if time to go, set days and time remaining
    Else
    TimeLeft = (Range("B2").Value + Range("C2").Value) - Now ' work out time left
    Range("B4") = Int(TimeLeft) ' set days left
    Range("C4") = TimeLeft - Range("B4") 'set hh:mm:ss left
End If

Timer 'start timer

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next 'in case timer isn't running
stop_timer

End Sub

The worksheet is proteced (as it leaves me) but if you could unprotect it (there's no password) if you want to stop the timer and change values in B2 and C2 e.g. to check what happens at day ends, for future days. 

Again, no guarantees on this. Also I haven't allowed you to set a target date/time but perhaps you can do that.

Suggest that you don't mess with the time interval 00:00:01 (a second).

Hope this helps.