Countdown Timer With Multiple Segments

[BikerDave]

I am trying to develop a countdown timer that will countdown multiple segments from a Worksheet and keep track of the total countdown time. The following code works for the first segment, but when I read the second segment, my time starts counting by two, when I reach the third segment it counts down by three, etc.... I'm stuck trying to figure out how to get the timer, or probably more correctly, the displayed time, to countdown every one second.

Thanks in advance for your help.

Option Explicit


Public Routine
Public STime As Single
Public Segment As Integer
Public SegmentCount As Integer
Public StimeDisplay As Date
Public StimeStarted As Date
Public StimeContinueAutomation As Date
Public TtimeDisplay As Date
Public timeStarted As Date
Public timeContinueAutomation As Date
Public bAbort As Boolean
Public bContinue As Boolean
Public runWhen As Double


Public waitHours As Integer
Public waitMins As Integer
Public waitSecs As Integer


Public swaitHours As Integer
Public swaitMins As Integer
Public swaitSecs As Integer


Public Sub Timer()


    bAbort = False
    bContinue = False


    timeStarted = Now()
    timeContinueAutomation = Now() + TimeSerial(swaitHours, swaitMins, swaitSecs) 'How much time until the process continues the automation
    
    Application.OnTime earliesttime:=timeContinueAutomation, procedure:="continueAutomation", schedule:=True
    Application.OnTime earliesttime:=Now() + TimeSerial(0, 0, 1), procedure:="updateCountDownLabel", schedule:=True  'This line is triggered an additional time each time through sub


End Sub
Sub updateCountDownLabel()
    
    If Not bAbort And Not bContinue Then
        TtimeDisplay = TtimeDisplay - TimeSerial(0, 0, 1)
        StimeDisplay = StimeDisplay - TimeSerial(0, 0, 1)


        frmrun.TxtBoxSTime = Format(StimeDisplay, "HH:MM:SS")
        frmrun.TxtBoxTTime = Format(TtimeDisplay, "HH:MM:SS")
        
        runWhen = Now() + TimeSerial(0, 0, 1)
        'Debug.Print "scheduling " & runWhen
        Application.OnTime earliesttime:=runWhen, procedure:="updateCountDownLabel", schedule:=True
    Else
        Call stopTimerUpdateCountDownLabel
    End If
    
End Sub
Sub stopTimerUpdateCountDownLabel()


        On Error Resume Next
        'Debug.Print "cancelling " & runWhen
        Application.OnTime earliesttime:=runWhen, procedure:="updateCountDownLabel", schedule:=False
        On Error GoTo 0
        
End Sub
Public Sub continueAutomation()


    If Not bAbort And Not bContinue Then
        Call macroToRun
    End If
    
End Sub


Sub macroToRun()


    bContinue = True


    If Segment < (SegmentCount + 1) Then
    
        Segment = Segment + 1
        
        frmrun.TxtBoxCZone = Worksheets(Routine).Range("c" & Segment)
        frmrun.TxtBoxNZone = Worksheets(Routine).Range("c" & Segment + 1)
        frmrun.TxtBoxCCad = Worksheets(Routine).Range("d" & Segment)
        frmrun.TxtBoxNCad = Worksheets(Routine).Range("d" & Segment + 1)
           
        swaitHours = 0                                                  ' Defines next Segment hours
        swaitMins = 0                                                   ' Defines next Segment minutes
        swaitSecs = Worksheets(Routine).Range("b" & Segment) * 60       ' Defines next Total seconds
          
        StimeDisplay = TimeSerial(swaitHours, swaitMins, swaitSecs)
        frmrun.TxtBoxSTime = Format(StimeDisplay, "HH:MM:SS")


        Call Timer
        
    Else


       MsgBox "done"


    End If


End Sub