need help sync countdown timer with system time

[Efrye]

I have two countdown timers running weekly hours and monthly hours. What I need is to sync the timer with the system time to avoid the macro of one timer stopping when a message box pops up when one of the timers reach zero. example: Weekly countdown timer reaches 00:00:00, a message box pops up with what needs to be done. The message box pauses the monthly timer but it activates again when the message box is closed, but the timer starts off on its normal countdown and does not re calculate for the seconds lost while the message box was opened. I have looked all over online and could not find a way around the message box pausing the macros. Is there any way to sync a countdown timer to the system clock so it updates itself after the message box is closed? I have cells "B2"and "B3" formatted as 00:00:00 time with 2 start/reset buttons for each cell.

ublic Sub StartCountdown1()
     StopTimer
     CountdownTime = ("7") 'number of days will convert to hours using 00:00:00
     UpdateCountdown
 End Sub



 Public Sub UpdateCountdown()

     Worksheets("Pm Scheduler").Range("B2").Value = CountdownTime
     CountdownTime = DateAdd("s", -cRunIntervalSeconds, CountdownTime)
     
     If CountdownTime > 0 Then
         'Reschedule this procedure
         RunWhen = DateAdd("s", cRunIntervalSeconds, Now)
         Application.OnTime EarliestTime:=RunWhen, procedure:=cRunWhat, Schedule:=True
         
     Else
         'Play sound when countdown reaches zero and reset to 30 seconds
         sndPlaySound32 "C:\Windows\Media\ding.wav", &H1
         Worksheets("Pm Scheduler").Range("B2").Value = TimeValue("00:00:00")
         Application.OnTime Now + TimeValue("00:00:02"), "ShowMsgbox"
    End If
    
        
 End Sub
 

 Public Sub StopTimer()
     On Error Resume Next
     Application.OnTime EarliestTime:=RunWhen, procedure:=cRunWhat, Schedule:=False
 End Sub
 


Sub showmsgbox()
'Shell ("C:\Program Files\Windows NT\Accessories\wordpad.exe")
'Workbooks.Open Filename:=("C:\Program Files\Windows NT\Accessories\testing this out.rtf")

MsgBox ("1) Check oil level and top off if needed" & vbNewLine & "2) Check for proper functioning of safety switch") & vbNewLine & "3) Clean and lubricate table plate" & vbNewLine & "4) Clean tool holder" & vbNewLine & "5) Drain off condensation from air filter water seperator" & vbNewLine & "6) Clean Attachment rail for gauge finger displacement (Z axis)" & vbNewLine & "7) Clean Guide of support bracket", , "Trumpf 5130 Weekly PM."
If -vbOK Then

 Run ("getusername")
End If


End Sub


Sub GetUserName()

Dim strName As String
Dim lr As Long
          
    strName = InputBox("Preventative Maintenence Completed by" & vbNewLine & vbNewLine & vbNewLine & vbNewLine & "Name and Date", "Weekly PM for Trumpf 5130")
        If strName = "" Then
    Run ("getusername")
Else
    lr = Sheet2.Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheet2.Range("A" & lr).Value = strName & vbNewLine & Now()
    
End If
          
          
End Sub

If I can get help with this I can finally finish this project. Thanks

 

[RickXL]

Hi,

I once did one like this:

The cells in column D have formulas like this:

=B2+C2-NOW()

The buttons reset the start times in column B to "NOW". The code for these goes into a Sheet Module:

Private Sub CommandButton1_Click()
    Range("B2").Value = Now
End Sub
Private Sub CommandButton2_Click()
    Range("B3").Value = Now
End Sub
Private Sub CommandButton3_Click()
    Range("B4").Value = Now
End Sub
Private Sub CommandButton4_Click()
    Range("B5").Value = Now
End Sub

The duration is set by the user in column C.

All that is needed is for the worksheet to Calculate. This macro needs to be pasted in to a standard Module.:

Sub sheet_calc()
    Application.OnTime Now + TimeValue("00:00:01"), "sheet_calc"
    ActiveSheet.Calculate
End Sub

The calculation can be delayed by MsgBoxes etc but the timers all work from the system time. So you can close the workbook and re-open it and it will still be keeping time.

The ThisWorkbook module has this to get it started when the workbook is opened:

Private Sub Workbook_Open()
    sheet_calc
End Sub

Conditional Formatting turns cells red for the last hour - it was a long term timer.

 

[Efrye]

This is really close to what I am looking for. I will try and work with this and get it to sync with the time format I use. I have mine set up to register days in the hours format. Will work on it tomorrow and post results. Thanks a lot RickXL

 

[Efrye]

Ok so I have restructured it a bit for my needs and is working just like I need it to. RickXL you have saved me countless hours of trying to figure this out with your method thank you.


Password protected buttons for resetting the timer so nobody cheats hehe.

Private Sub CommandButton1_Click()
    Response = Application.InputBox("Enter Password to execute", "Password Required")
If Not Response = "zebra" Then Exit Sub
    Range("F2").Value = Now
    Run "COUNTDOWN1"
    End Sub
    
Private Sub CommandButton2_Click()
    Response = Application.InputBox("Enter Password to execute", "Password Required")
If Not Response = "zebra" Then Exit Sub
    Range("F3").Value = Now
    Run "COUNTDOWN2"
    End Sub

automatically starts recalculating when workbook is open

Private Sub Workbook_Open()
    Recalc
End Sub

Sub sheet_calc()

    Application.OnTime Now + asdate, "recalc"
    ActiveSheet.Calculate
End Sub

This code loops and keeps the timer counting down in 1 second intervals until a timer reaches 0 and activates a messagebox

Dim SchedRecalc As Date

Sub Recalc()
'or use the following line if you have a cell you wish to update
Range("d2").Calculate
Call StartTime1 ' need to keep calling the timer, as the ontime only runs once
Call range1
Call range2

End Sub
Sub range1()
If Worksheets("SHEET1").Range("D2") < 0 Then
Run "MESSAGEBOX1"
End If
End Sub
Sub range2()
If Worksheets("SHEET1").Range("D3") < 0 Then
Run "MESSAGEBOX2"
End If
End Sub

Sub StartTime1()
SchedRecalc = Now + TimeValue("00:00:01")
Application.OnTime SchedRecalc, "Recalc"


End Sub

Sub EndTime()
On Error Resume Next
Application.OnTime EarliestTime:=SchedRecalc, _
        Procedure:="Recalc", Schedule:=False
End Sub

Message box pops depending on what range in the last code I posted reaches 0 with what is needed to be done as well as triggers an inputbox that requires a name to be entered and populates it on sheet2 with the date. users can not exit the inputbox without entering text. I split up the range calls into separate modules

Sub COUNTDOWN1() 'change name for each timer
If Worksheets("SHEET1").Range("D2") < 0 Then ' change range for each timer
        Run "MESSAGEBOX1" 'change name for each timer
        Else
        Run "RECALC"
    End If
End Sub


Sub MESSAGEBOX1() 'change the name of "showmsgbox" for each sub

MsgBox ("1) Check oil level and top off if needed" & vbNewLine & "2) Check for proper functioning of safety switch") & vbNewLine & "3) Clean and lubricate table plate" & vbNewLine & "4) Clean tool holder" & vbNewLine & "5) Drain off condensation from air filter water seperator" & vbNewLine & "6) Clean Attachment rail for gauge finger displacement (Z axis)" & vbNewLine & "7) Clean Guide of support bracket", , "Trumpf 5130 Weekly PM."
If -vbOK Then '<----WEEKLY 5130 PM LIST

 Run ("getusername1") ' change name for each timer

End If

End Sub

Sub GetUserName1() 'change the name of "getusername" for each sub

Dim strName As String
Dim lr As Long
          'Change title depending on PM type. Example. Weekly, Monthly, Semi annual, Etc.
    strName = InputBox("Preventative Maintenence Completed by" & vbNewLine & vbNewLine & vbNewLine & vbNewLine & "Name", "Weekly PM for Trumpf 5130")
        If strName = "" Then
    Run ("getusername1") 'change name for each timer
Else
    lr = Sheet2.Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheet2.Range("A" & lr).Value = strName & vbNewLine & Now()
    Range("F2").Value = Now
    Run "RECALC"

 

[RickXL]

Thanks for the update.

You seem to be running ReCalc and Application.OnTime a lot? I only needed one call and it kept running till I closed Excel. Then it automatically re-starts the next time you open the WorkBook.

Anyway, if you are happy that is the main thing.

Regards,