Multiple Timers, Multiple Events

Hi there,

Take a look at the attached workbook and see if it gets you moving in the right direction. It uses the following code in the VBA CodeModule for the worksheet:

Option Explicit


'=========================================================================================
'=========================================================================================


Const msPROCEDURE_NAME  As String = "UpdateTimers"


'=========================================================================================
'=========================================================================================


Private mdteNextTime    As Date


'=========================================================================================
'=========================================================================================


Private Sub Worksheet_Change(ByVal Target As Range)

    Const sCOLUMN_CHANGE    As String = "B"
    Const sCOLUMN_START     As String = "C"
    Const sCOLUMN_TIMER     As String = "D"
    Const iFIRST_ROW_NO     As Integer = 3
    Const sFORMULA          As String = "=NOW() - INT(NOW()) - RC[-1]"

    Dim rTarget             As Range

    Set rTarget = Target

    If rTarget.Cells.CountLarge = 1 Then

        If rTarget.Column = Me.Columns(sCOLUMN_CHANGE).Column And _
           rTarget.Row >= iFIRST_ROW_NO Then

            Intersect(rTarget.EntireRow, _
                      Me.Columns(sCOLUMN_START)).Value = Now() - Int(Now())

            Intersect(rTarget.EntireRow, _
                      Me.Columns(sCOLUMN_TIMER)).FormulaR1C1 = sFORMULA

            Call UpdateTimers

        End If

    End If

End Sub


'=========================================================================================
'=========================================================================================


Private Sub UpdateTimers()

    Const iUPDATE_INTERVAL  As Integer = 1  '<<  Interval in seconds between timer updates

    Dim dteInterval         As Date

    dteInterval = TimeValue("00:00:" & Format(iUPDATE_INTERVAL, "00"))

    If mdteNextTime > 0 Then
          mdteNextTime = mdteNextTime + dteInterval
    Else: mdteNextTime = Now() + dteInterval
    End If

    Me.Calculate

    Application.OnTime EarliestTime:=mdteNextTime, _
                       Procedure:=Me.Name & "." & msPROCEDURE_NAME

End Sub


'=========================================================================================
'=========================================================================================


Private Sub StopProcess()

    On Error Resume Next

        Application.OnTime EarliestTime:=mdteNextTime, _
                           Procedure:=Me.Name & "." & msPROCEDURE_NAME, Schedule:=False

        mdteNextTime = 0

    On Error GoTo 0

End Sub

The highlighted values may be altered to suit your requirements, but note that the following line:

Const sFORMULA          As String = "=NOW() - INT(NOW()) - RC[-1]"

assumes that the "Start" and "Elapsed" columns are adjacent to each other.

Hope this helps - please let me know how you get on.

Regards,

Greg M

This is super helpful and we can make this work swimmingly, thank you! I'm wondering if it's possible to make each line stop when it hits an hour. Everything I have thought of would stop all of them when the first one hits an hour. Any insights into accomplishing this?

I changed Const sFORMULATE to "=IF(NOW()-INT(NOW())-RC[-1]<0.04167,NOW()-INT(NOW())-RC[-1],0.04167)" and was able to have each line item stop as an hour. This made our project exactly as we had hoped, thank you for your help!

Hi again,

Sorry about the delay in replying - other projects got in the way of the forum!

Many thanks for all of your feedback and also for the recent Reputation increase - much appreciated!

You're welcome - glad I was able to help.

Best regards,

Greg M