Hi all,
I am very new to using VBA in excel. I have been trying to create a timer on excel that can be embedded several times in the same sheet and can run independent from each other. I found the following code on another webpage that allows me to embed a timer in a single cell and counts down after you tell it what the expiration time is.
example = current time is noon, and I want the expiration time to 1300 hours, so I put in 1300 in the formula and the timer starts to count down from 2:00:00 (2 hours).
This is exactly what I needed, but if you set a time for 3am and it is 9pm currently the timer just sets itself at 0:0:0. I was wondering if there is anything that can be changed in the code to avoid this. I was also wondering if there is a way to add in a function that will turn the timer red when there is one hour left on the countdown.
I will post the code below and would appreciate any help. I knew some basic c++ back in the day but I have no experience doing this. Let me know if there is any more information I can provide to help. Also this is for a completely non-profit project.
The code is this (instructions between lines, must be removed to run)
in the project explorer window (open that window using the "View" menu if it isn't open already), locate your file and double click on it.
- Choose "Insert, Class module" from the menu
- Open the properties window (View, properties) and change the Name of the class (now reads "Class1") to clsTimer.
- IN the code window of clsTimer paste this code:
[VBA]Option Explicit
Private msCellAddress As String
Private mdtEndTime As Date
Public Property Get CellAddress() As String
CellAddress = msCellAddress
End Property
Public Property Let CellAddress(ByVal sCellAddress As String)
msCellAddress = sCellAddress
End Property
Public Property Get EndTime() As Date
EndTime = mdtEndTime
End Property
Public Property Let EndTime(ByVal dtEndTime As Date)
mdtEndTime = dtEndTime
End Property[/VBA]
- Insert a module (Insert, module from the menu)
- paste in this code:
[VBA]Option Explicit
Private mdNextTime As Double
Private mcolTimers As Collection
Public Function CountDown(EndTime As Date) As Variant
Dim cTimer As clsTimer
Dim sCellAddress As String
sCellAddress = Application.Caller.Address(external:=True)
Application.Volatile
If TypeName(Application.Caller) <> "Range" Then
Else
If IsIn(mcolTimers, sCellAddress) Then
Set cTimer = mcolTimers(sCellAddress)
mcolTimers.Remove sCellAddress
Else
Set cTimer = New clsTimer
With cTimer
.CellAddress = sCellAddress
.EndTime = EndTime
End With
End If
End If
With cTimer
.CellAddress = sCellAddress
.EndTime = EndTime
If .EndTime - (Now - Int(Now)) > 0 Then
CountDown = .EndTime - (Now - Int(Now))
Else
CountDown = 0
End If
End With
If mcolTimers Is Nothing Then
Set mcolTimers = New Collection
End If
mcolTimers.Add cTimer, sCellAddress
Set cTimer = Nothing
End Function
Private Function IsIn(colCollection As Collection, sName As String)
Dim cTimer As clsTimer
On Error Resume Next
Set cTimer = mcolTimers(sName)
IsIn = (Err.Number = 0)
Set cTimer = Nothing
End Function
Public Sub Auto_Open()
Application.OnTime Now, "UpdateTimers"
End Sub
Public Sub Auto_Close()
StopTimers
End Sub
Sub UpdateTimers()
mdNextTime = Now + TimeValue("00:00:01")
Application.OnTime mdNextTime, "UpdateTimers"
Application.Calculate
End Sub
Sub StopTimers()
Application.OnTime mdNextTime, "UpdateTimers", , False
End Sub[/VBA]
- Now in any cell, enter a formula like this:
=CountDown(Time(16,20,00))
and format the cell as time.
- Save your file, close it and open it again.
The cell should start to count down to 00:00 (which it reaches at whatever time you entered).
I thank you in advance for any help,
LD
Reply With Quote
