Running multiple timers in MS Excel using VBA

Question

I am trying to run multiple timers in different cells in MS Excel. I want to stop the timer only on the selected active cell.

The problem is that when I start the timer on another cell, the previous timer on a previously chosen cell stops.

The program starts the timer upon double clicking.

The functions have been assigned to macros.

For a clearer explanation, let's say I start the timer in Cell A1 by double clicking (as coded in my Worksheet). Now, if I start the timer in Cell A2, then the timer in Cell A1 stops, and the timer in Cell A2 runs. I want to run both the timers and stop the timer in the Cell I select while the other still runs.

Option Explicit

Dim Tick As Date, t As Date
Global myCell  As Range

Sub stopwatch()
    t = Time
    Call StartTimer
End Sub

Sub StartTimer()
    Tick = Time + TimeValue("00:00:01")
    myCell.Value = Format(Tick - t - TimeValue("00:00:01"), "hh:mm:ss")
    Application.OnTime Tick, "StartTimer"
End Sub

Sub StopTimer()
    On Error Resume Next
    Application.OnTime EarliestTime:=Tick, Procedure:="StartTimer", Schedule:=False
End Sub

In my worksheet, this code starts the timer on double click:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Set myCell = Target
    StartTimer
    Cancel = True
End Sub

Answer 1

Try this - using a Dictionary to track which cells have timers running. Double-click a cell to start a timer there: double-click again to stop.

This code is all in the Sheet3 module (codename)

Option Explicit

Dim timers As Object 'cell addresses as keys and start times as values
Dim nextTime         'next run time

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    ToggleTimer Target
    Cancel = True
End Sub

Sub ToggleTimer(Optional c As Range = Nothing)
    Dim addr As String, k, macro
    
    If timers Is Nothing Then Set timers = CreateObject("scripting.dictionary")
    
    macro = Me.CodeName & ".ToggleTimer"
    On Error Resume Next 'cancel any running timer
    Application.OnTime EarliestTime:=nextTime, Procedure:=macro, Schedule:=False
    On Error GoTo 0
    
    If Not c Is Nothing Then  '? called from a cell double-click ?
        addr = c.Address(False, False)
        If timers.exists(addr) Then
            timers.Remove addr  ' timer was running - remove it
        Else
            timers(addr) = Now  ' timer was not running - add it
        End If
    End If
    If timers.Count = 0 Then Exit Sub 'no more timers
    
    For Each k In timers  'update timer(s)
        Me.Range(k).Value = Format(Now - timers(k), "hh:mm:ss")
    Next k
    
    'schedule next run
    nextTime = Now + TimeSerial(0, 0, 1)
    Application.OnTime nextTime, Me.CodeName & ".ToggleTimer"
    Debug.Print Me.CodeName
End Sub