Problem Running multiple timers in MS excel using VBA-CodePudding

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 when I am starting the timer on another cell. The previous timer on a previously chosen cell automatically stops.

The program I have now starts the timer upon double clicking.

I am trying to run different timers on the different cells and I want to stop the timer on the selected cells only using macros.

Here is what I have done so far: 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 A1 stops, and the timer in A2 runs. I want to run both the timers and stop the timer on the cell I select only while the other should still run.

I am scratching my head as to how I should modify my code to achieve this.

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 , I have this code to start the timer on double click:

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

CodePudding user response：

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