I'm trying to learn countdown macros and I downloaded this file from Jerry Beaucaire's website. Thank you Jerry!
I tweaked it a little. Rather than counting a value from 0 to an infinite number, I made it to countdown a value to zero from a number that I type in column C. But an error occurs when a number reaches zero. How do I fix this error? And how do I make a button in column A switch back to "DOWN" when a number reaches zero?
Dim CountDown As Date
Sub Timer()
DisableTimer
CountDown = Now + TimeValue("00:00:01")
Application.OnTime CountDown, "Reset"
End Sub
Sub Reset()
Dim Counter As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
If Evaluate("COUNT(B2:B5)") = 0 Then
Call DisableTimer
Else
For Each Counter In ThisWorkbook.Sheets("Sheet1").Range("B2:B5")
If Not IsEmpty(Counter) Then Counter = Counter - TimeValue("00:00:01")
Next Counter
Call Timer
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub DisableTimer()
On Error Resume Next
Application.OnTime EarliestTime:=CountDown, Procedure:="Reset", Schedule:=False
End Sub
Source File
Replace this:
If Not IsEmpty(Counter) Then Counter = Counter - TimeValue("00:00:01")
With this:
If Counter > TimeValue("00:00:01") Then
Counter = Counter - TimeValue("00:00:01")
Else
Counter = ""
End If
Related
I'm attempting to make a GUI for a school project in Excel of a basic security system. I'm trying to have the macro take the user to the alarm slide (slide 8) if the timer runs out and if the disarm boolean is false. However, as I have it now, no matter what the user is always taken to the alarm slide once the timer runs out. I'm not sure what the issue is exactly.
The ARM_DISARM is run by an action button on the disarmed slide.
Global Disarm As Boolean
Sub timelimit()
Disarm = False
ActivePresentation.SlideShowWindow.View.GotoSlide (3)
Dim time As Date
time = Now()
Dim count As Integer
count = 5
time = DateAdd("s", count, time)
Do Until time < Now()
DoEvents
For i = 3 To 6 'slide numbers'
ActivePresentation.Slides(i).Shapes("countdown").TextFrame.TextRange = Format((time - Now()), "hh:mm:ss")
Next i
Loop
If Disarm = False Then
ActivePresentation.SlideShowWindow.View.GotoSlide (8)
End If
End Sub
Sub ARM_DISARM()
Disarm = True
End Sub
avid reader, first time poster here. I have a Macro that I obtained from the internet for the most part, then made some adjustments. It's purpose is to color code cells that have passed a certain duration. It was working fine earlier, but now I am getting an error on it for a "Type Mismatch". The line that reads "This is where the error is" is where I am getting the mismatch. I am puzzled because it was working fine earlier. I am not a seasoned programmer by any means, but I just try to troubleshoot things. I have looked all over the net and cant find a specific answer to my question.
In addition, if any of you are willing, I would appreciate your advice on how to make this code run ONLY at startup of the workbook and NOT periodically as it is set up to do so now.This code is not placed in a worksheet, but in a Module.I mention this because I am not sure how much of a practical difference it can make any help is appreciated, thanks!
Public TimeToRun As Date
Sub Auto_Open()
Call ScheduleCompareTime
End Sub
Sub ScheduleCompareTime()
TimeToRun = Now + TimeValue("00:00:10")
Application.OnTime TimeToRun, "CompareTimeStamp"
End Sub
Sub CompareTimeStamp()
Dim rgTimeStamp As Range
Dim rdTimeStamp As Range
Dim i As Long
Dim j As Long
Dim MyNow As Date
Dim TimeStamp As Date, TimeStampp As Date
Set rgTimeStamp = Range("c1:c500")
Set rdTimeStamp = Range("H1:h500")
For i = 1 To rgTimeStamp.Rows.Count
If Not rgTimeStamp.Cells(i, 1) < 1 Then 'don't run for an empty cell
MyNow = CDate(Now - TimeSerial(0, 0, 0)) 'time instantly
TimeStamp = CDate(rgTimeStamp.Cells(i, 1)) 'THIS IS WHERE THE ERROR IS!!
If TimeStamp < MyNow Then 'if it's old at all
rgTimeStamp.Cells(i, 1).Interior.ColorIndex = 3 'make fill colour red
End If
End If
Next
For j = 1 To rdTimeStamp.Rows.Count
If Not rdTimeStamp.Cells(j, 1) < 1 Then
MyNow = CDate(Now - TimeSerial(0, 0, 0))
TimeStampp = CDate(rdTimeStamp.Cells(j, 1))
If TimeStampp < MyNow Then
rdTimeStamp.Cells(j, 1).Interior.ColorIndex = 3
End If
End If 'closes If Not
Next
Call ScheduleCompareTime 'begins the scheduler again
End Sub
Sub auto_close() 'turn the scheduler off so you can close workbook
Application.OnTime TimeToRun, "CompareTimeStamp", , False
End Sub
You probably have data in one or more cells that Excel cannot convert to a date. You can get around this by adding some simple checking such as this:
'.... beginning of your code
If Not rgTimeStamp.Cells(i, 1) < 1 Then 'don't run for an empty cell
MyNow = CDate(Now - TimeSerial(0, 0, 0)) 'time instantly
If IsDate(rgTimeStamp.Cells(i, 1)) = False Then
MsgBox "Invalid date found in cell " & rgTimeStamp.Cells(i, 1).Address(False, False)
Exit Sub
End If
TimeStamp = CDate(rgTimeStamp.Cells(i, 1)) 'THIS IS WHERE THE ERROR IS!!
If TimeStamp < MyNow Then 'if it's old at all
rgTimeStamp.Cells(i, 1).Interior.ColorIndex = 3 'make fill colour red
End If
End If
'... rest of your code
If you only want the code to run at startup then change Sub Auto_Open to this:
Sub Auto_Open()
Call CompareTimeStamp
End Sub
First of all I should say that I have no relevant experience in VBA but I badly need to make a timer in excel. I have managed to create stop and start buttons of the timer. But I have 20 different timers with start and stop buttons. I want to create a button that will be automatically start all timers while letting me stop individually a single timer.
I have produced the following code to start and stop them. But when I stop one of the timers I get the following error:"Run-time error '1004': Method 'onTime' of object'_application failed.
The code for the two start and stop buttons is:
Sub startTimer27()
Application.OnTime Now + TimeValue("00:00:01"), "Increment_count27"
End Sub
Sub Increment_count27()
Range("B2").Value = Range("B2") + 1
Range("B11").Value = Range("B11") + 1
Range("B19").Value = Range("B19") + 1
Range("B25").Value = Range("B25") + 1
Range("B33").Value = Range("B33") + 1
startTimer27
End Sub
Sub stopTimer27()
Application.OnTime Now + TimeValue("00:00:01"), "Increment_count27", Schedule:=False
End Sub
Have you considered using global variables saving the current time value?
Sub startTimer27()
starttime = Now
'MsgBox("The timer is running.")
End Sub
Sub stopTimer27()
timetaken = Now - starttime
MsgBox ("The time elapsed is " & Hour(timetaken) & ":" & Minute(timetaken) & ":" & Second(timetaken))
End Sub
Of course with your example it would be more like:
Public starttime(1 To 20) As Date
Sub cvbstartTimer27()
For i = 1 To 20
starttime(i) = Now
Next
End Sub
If you need to specifically stop it, then you'd have to give it a Boolean value too, that would be true when the timer is running and false when it's stopped. The lack of this value doesn't mean your code is wrong nevertheless.
I have some code here that works perfectly except for when I try to close the Excel Sheet. I have tried to program the timer to stop when i close the Workbook but it does not seem to be working. Whenever I close the workbook it automatically re-opens. Any help with tweaking my code would be gratly appreciated. Here it is:
Code in Module 1:
Dim RT1 As Date
Dim Lunch As Date
Dim ApT As Date
Dim RT3 As Date
Dim NextTick As Date
Public Sub UpdateTime()
' Places a bug fix for stopping the clock when closing the workbook
Debug.Print "UpdateTime" & Format(RunWhen, "00:00:00")
' Updates cell D8 with the Current time
ThisWorkbook.Sheets(1).Range("D8") = Now()
' Set up next event 1 second from now
NextTick = Now + TimeValue("00:00:01")
Application.OnTime NextTick, "UpdateTime"
End Sub
Public Sub StopClock()
' Cancels the OnTime event
On Error Resume Next
Application.OnTime NextTick, "UpdateTime", , False
End Sub
Code in Module 2:
Sub PhoneHours()
'Time left at the beginning of the day
If Range("B12") < Range("A3") Then Range("E12").FormulaR1C1 = "=(R[3]C[-3]-R[0]C[-3])- (2*R[0]C[1])"
'Time left after the first Research Time Has passed
If Range("B12") >= Range("A3") Then Range("E12").FormulaR1C1 = "=(R[3]C[-3]-R[0]C[-3])- (1.75*R[0]C[1])"
'Time left after Lunch and Second Research Time
If Range("B12") >= Range("B3") Then Range("E12").FormulaR1C1 = "=(R[3]C[-3]-R[0]C[-3])- (0.5*R[0]C[1])"
'Time left afetr Apple Time
If Range("B12") >= Range("D3") Then Range("E12").FormulaR1C1 = "=(R[3]C[-3]-R[0]C[-3])- (0.25*R[0]C[1])"
'Time left after Final Research Time
If Range("B12") >= Range("E3") Then Range("E12").FormulaR1C1 = "=(R[3]C[-3]-R[0]C[-3])"
NextCheck = Now + TimeValue("00:00:10")
Application.OnTime NextCheck, "PhoneHours"
End Sub
Sub StopCheck()
' Cancels the OnTime event
On Error Resume Next
Application.OnTime NextCheck, "PhoneHours", , False
End Sub
Code in ThisWorkbook:
Sub Worksheet_Deactivate()
Call StopClock
Call StopCheck
End Sub
Sub Workbook_Activate()
Call UpdateTime
Call PhoneHours
End Sub
Sub Workbook_Open()
Call UpdateTime
Call PhoneHours
End Sub
Sub Workbook_Close()
Call StopClock
Call StopCheck
End Sub
Thanks in Advance!
When I tried do something similar I found that the main problem was that OnTime calls were being raised far more frequently than I expected - if you put a debug.print in your PhoneHours sub then you'll see that this is the case here. Your StopCheck routine is only cancelling the latest call, but all earlier ones are still active (and are causing the book to be reopened after closing).
You may want to create some breakpoints/debugs to find out exactly where and why each one is being called in order to make your sheet run more efficiently, but in any case I found that the most reliable way of cancelling all future ontime calls was a bit of a scattergun approach as follows:
Sub StopCheck()
' Cancels the OnTime event
Debug.Print "Cancelled Phonehours"
On Error Resume Next
' Cancels all OnTime events scheduled in the next 15 seconds
For i = 0 To 15
Application.OnTime Now + TimeValue("00:00:" & i), "PhoneHours", , False
Next i
On Error GoTo 0
End Sub
and
Public Sub StopClock()
' Cancels the OnTime event
On Error Resume Next
Debug.Print "Cancelled UpdateTime"
' Cancels all OnTime events scheduled in the next 3 seconds
For i = 0 To 3
Application.OnTime Now + TimeValue("00:00:" & i), "UpdateTime", , False
Next i
On Error GoTo 0
End Sub
This should leave no remaining future OnTimes scheduled and you should be able to close your sheet successfully.
(Incidentally, should your Worksheet_Deactivate be a Workbook_Deactivate?)
Good morning,
I am working on a macro to autorefresh excel links before slideshow, loop through slideshow and then restart over and over again. The issue I am having is the slideshow stops but doesnt exit so the wait timer doesnt have a chance to even kick in.
Can I get a suggestion of how I might fix this?
Sub LoopAllSlides()
Dim i As Integer
For i = 0 To 2000
Dim Endpoint As Single
Endpoint = Timer + 10
Do While Timer < Endpoint 'This loop works dont delete
DoEvents
Loop
ActivePresentation.UpdateLinks
With ActivePresentation.SlideShowSettings
.AdvanceMode = ppSlideShowUseSlideTimings
.LoopUntilStopped = msoFalse
.Run
End With
Next i
End Sub
You can always do this with the Application.Quit function, which will exit out of your current sub. So, something like this:
Sub LoopAllSlides()
Dim i As Integer
For i = 0 To 2000
Dim Endpoint As Single
Endpoint = Timer + 10
Do While Timer < Endpoint 'This loop works dont delete
DoEvents
Loop
ActivePresentation.UpdateLinks
With ActivePresentation.SlideShowSettings
.AdvanceMode = ppSlideShowUseSlideTimings
.LoopUntilStopped = msoFalse
.Run
End With
Next i
'Quit Application Function
IWishICouldQuitYou
End Sub
Function IWishICouldQuitYou()
With Application
For Each w In .Presentations
w.Save
Next w
.Quit
End With
End Function