Optimize code for multiple timers on 1 sheet-CodePudding

This is what my sheet looks like:

(I got the code from online somewhere & just been adjust what I know)

I Currently have 10 rows with working buttons, but it's already at 500 lines of code and I still need 60more. I'm worried the file will become too large and start crashing.

Should I just keep changing the "Range(F#)" every time I make a new button/row?

Also, is it possible to keep more than 1 timer going at a time? Currently when I click stop on any of the rows it will stop whatever timer is active.

Public StopIt As Boolean
Public ResetIt As Boolean
Public LastTime


Private Sub cust10reset_Click()
  Range("F10").Value = Format(0, "00") & ":" & Format(0, "00") & ":" & Format(0, "00") & "." & Format(0, "00")
  LastTime = 0
  ResetIt = True
End Sub

Private Sub cust10start_Click()
Dim StartTime, FinishTime, TotalTime, PauseTime
StopIt = False
ResetIt = False
If Range("F10") = 0 Then
  StartTime = Timer
  PauseTime = 0
  LastTime = 0
Else
  StartTime = 0
  PauseTime = Timer
End If
StartIt:
  DoEvents
  If StopIt = True Then
    LastTime = TotalTime
    Exit Sub
  Else
    FinishTime = Timer
    TotalTime = FinishTime - StartTime   LastTime - PauseTime
    TTime = TotalTime * 100
    HM = TTime Mod 100
    TTime = TTime \ 100
    hh = TTime \ 3600
    TTime = TTime Mod 3600
    MM = TTime \ 60
    SS = TTime Mod 60
    Range("F10").Value = Format(hh, "00") & ":" & Format(MM, "00") & ":" & Format(SS, "00") & "." & Format(HM, "00")
    If ResetIt = True Then
      Range("F10") = Format(0, "00") & ":" & Format(0, "00") & ":" & Format(0, "00") & "." & Format(0, "00")
      LastTime = 0
      PauseTime = 0
      End
    End If
    GoTo StartIt
  End If
End Sub

Private Sub cust10stop_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  StopIt = True
End Sub

I tried making a dedicated formula tab and just make macros going my timer buttons but I couldn't get that to work.

I tried making a togglebutton and linking it to the cell then just make a code that references the linkedcell to know where to put the timer, but that wasn't working. It just kept coming back true/false.

I guess I just want to know if it's ok to have 4000 lines on 1 sheet with 210 buttons lol. Or just an easier way.

CodePudding user response：

What you could consider is to work with a Class module and a dictionary.

The Timer() command in XL merely generates a TimeStamp value that you can store for later use. You could do that in a dictionary with a particular class.

Create a Class module and name it cTimer add below code

Option Explicit
Private pTimer As Single

Public Sub StartTimer()
    
    pTimer = Timer()
    
End Sub

Property Get Elapsed() As Single
    
    Elapsed = Timer() - pTimer
    
End Property

Now, mind you, the portion of using the class may not strictly be required as you could simply add a dictionary entry for the address and Timer() value.

like so:

dict.Add Key, Timer()

But working with a class object allows you to create more functionality for each of the cTimer objects.

Now, to keep track of all the timers you can set add a new cTimer object to the dictionary based on the cell address of the button (this may need some fine tuning to ensure all your buttons eventually generate the same reference key) But that is the most important portion of it, the reference key.

In a code module, add the below, this will look for an existing entry in the dictionary and if it exists display the elapsed time otherwise a new cTimer object will be added to the dictionary with the address as the reference key.

Create a Module and add the following:

Global dict As Object 'this line should be all the way at the top of the module code!

Sub TestTimer()
        
    Dim rngButton As Range
    Dim mm As cTimer
    
    If dict Is Nothing Then
        Set dict = CreateObject("Scripting.Dictionary")
    End If
    
    Caller = Application.Caller
    Set rngButton = ActiveSheet.Buttons(Caller).TopLeftCell
    Key = rngButton.Address
    
    Set tmr = New cTimer
    tmr.StartTimer
    
    If Not dict.Exists(Key) Then
        dict.Add Key, tmr
    Else
        Set tmr = dict(Key)
        Debug.Print tmr.Elapsed
    End If

End Sub

This may obviously need some tweaking to suit your particular need, but this could well be the solution you aim for. As you can simply have all the buttons refer to the same Method (or Macro)

You should add some logic for removing times and for resetting them etc. but the concept works.

see also:

Finally this code goes in the worksheet code module:

Option Explicit

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

'This is called when youclickon a hyperlink
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    Dim txt As String, cLnk As Range, cTimer As Range, addr As String
    
    If timers Is Nothing Then Set timers = CreateObject("scripting.dictionary")
    
    Set cLnk = Target.Range                    'cell with clicked link
    Set cTimer = cLnk.EntireRow.Columns("B")   'cell with elapsed time
    addr = cTimer.Address(False, False)        'address of cell with elapsed time
    txt = Target.TextToDisplay                 'Start/Stop/Reset
    
    Select Case txt 'what action to take depends on the link's text
        Case "Stop"
            If timers.Exists(addr) Then timers.Remove addr
            Target.TextToDisplay = "Start" 'toggle link text
            cLnk.Interior.Color = vbGreen  'toggle cell color
        Case "Start"
            timers(addr) = Now
            Target.TextToDisplay = "Stop"
            cLnk.Interior.Color = vbRed
        Case "Reset"
            If timers.Exists(addr) Then 'timer is running?
                timers(addr) = Now  'just reset the start time
            Else
                cTimer.Value = 0    'clear the elapsed time
            End If
    End Select
    
    UpdateTimers
    
End Sub

'called using OnTime, or from the event handler
Sub UpdateTimers()
    Dim addr As String, k, macro
    
    macro = Me.CodeName & ".UpdateTimers"
    On Error Resume Next 'cancel any running timer
    Application.OnTime EarliestTime:=nextTime, Procedure:=macro, Schedule:=False
    On Error GoTo 0
    
    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
    
    nextTime = Now   TimeSerial(0, 0, 1) 'schedule next run
    Application.OnTime nextTime, macro
End Sub