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.
Related
I have created a simple userform with a text label. I have put this code on activation of userform to run remaining time from target time. It is good once it runs, but it does not count down... Seconds do not flick down ... etc.
Code
Private Sub UserForm_activate()
targtime = DateValue("28 Jun 2018") + TimeValue("18:37:00")
remtime = targtime - Now
Me.Label1 = Int(remtime) & " Days " & Format(remtime - Int(remtime), "HH:MM:SS")
End Sub
What am I doing wrong?
Put it in an endless loop and it would start ticking every second:
Private Sub UserForm_Activate()
Dim remTime As Date
While True
remTime = DateValue("28 Jun 2018") + TimeValue("18:37:00") - Now
Me.Label1 = Int(remTime) & " Days " & Format(remTime - Int(remTime), "HH:MM:SS")
Me.Repaint
Application.Wait Now + #12:00:01 AM#
Wend
End Sub
I am trying to work out how to get my progress bar to show the progress of the subroutine below. Does anyone have any ideas how to get the ball rolling on this one?
Any help or advice is appreciated.
Private Sub CommandButton8_Click()
Dim StartTime As Double
Dim MinutesElapsed As String
'Remember time when macro starts
StartTime = Timer
'*****************************
'Direct Data
Sheet4.Activate
Call Test1
Call Test2
Call Test3
Call Test4
'Return to Welcome Page
Sheet8.Activate
'*****************************
'Determine how many seconds the code took to run
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
'Notify user in seconds
MsgBox "This code ran successfully in " & MinutesElapsed & " minutes",
vbInformation
End Sub
Here's what I use for a progress bar:
Application.StatusBar = "Processing... " & CInt(nRow / nLastRow * 100) & "% " & String(CInt(nRow / nLastRow * 100), ChrW(9609))
DoEvents ' optional
nRow is the increment number
nLastRow is the value for 100% complete
When the loop is complete, reset it like this:
Application.StatusBar = ""
The logic behind a progressbar is this:
have a userform with a Label (or image or button) with the image of your example photo. Put it in a frame. The width of the frame is initialised to zero and grows as your number grows by either calling a Public Sub inside the userform, of directly Userform1.Frame1.width=Percent*MaxWidth/100.
Sometime you would want to add a doevents, wich i use only every X cycles (if clng(percent) mod X = 0 then doevents , for example).
Step 1: design a progress dialog box. For the following example, it must have the name frmProgress and have two text labels lblMsg1 and lblMsg2
Step 2: insert the following code in the dialog's code module:
Sub ShowProgressBox()
Me.Show vbModeless
End Sub
Sub SetProgressMsg(msg1, msg2)
If (msg1 <> "") Then Me.lblMsg1 = msg1
If (msg2 <> "") Then Me.lblMsg2 = msg2
DoEvents
End Sub
Sub SetProgressTitle(title)
Me.Caption = title
DoEvents
End Sub
Sub EndProgressBox()
Unload Me
End Sub
You can call these functions from your code to show progress messages.
Step 3: in your code, at the beginning of the lengthy operation, call
frmProgress.ShowProgressBox
Step 4: during the lengthy operation, regularly call the set function to show the user information, for example in a loop:
frmProgress.SetProgressMsg "Searching in "+ myArray(i), "Working..."
Step 5: Once done, close the progress box:
frmProgress.EndProgressBox
I've made a workbook what has to be closed after 10 minutes of inactivity. I use a timer with Application.OnTime. I use the Application.OnTime command after every minute of inactivity, to refresh a message in the statusbar. In the last minute I use the Application.OnTime command after every second of inactivity to speed up the messages in the statusbar.
This works well, so far so good.
Public dtNextTime As Date
Public lngWaitTime As Long
Public lngRefreshTime As Long
Sub StartCountDownTimer()
Call StopCountDownTimer
dtNextTime = 0
lngWaitTime = 1 * 60 ' In my real workbook, the user can change the 10 minutes in a cell and I use this value in this sub
' Set initial RefreshTime
lngRefreshTime = 60
Call PlanNextTime
End Sub
Sub PlanNextTime()
Dim strWaitTime As String
Dim lngShowWaitTime As Long
If lngWaitTime >= 60 Then
lngShowWaitTime = lngWaitTime / 60
Else
lngShowWaitTime = lngWaitTime
End If
Select Case lngWaitTime
Case Is >= 120
strWaitTime = " minutes"
Case Is >= 60
strWaitTime = " minute"
Case Is > 1
strWaitTime = " seconds"
Case Is = 1
strWaitTime = " second"
End Select
Application.StatusBar = "If you don't use this workbook it will be closed in " & lngShowWaitTime & strWaitTime
If lngWaitTime <= 0 Then
Application.StatusBar = "Workbook is being closed"
Call CloseWorkbook
Else
If dtNextTime = 0 Then dtNextTime = Now()
If lngWaitTime > 60 Then
lngRefreshTime = 60
Else
lngRefreshTime = 1
End If
Application.OnTime EarliestTime:=dtNextTime, Procedure:="PlanNextTime", Schedule:=True
dtNextTime = dtNextTime + TimeSerial(0, 0, lngRefreshTime)
lngWaitTime = lngWaitTime - lngRefreshTime
End If
End Sub
Sub StopCountDownTimer()
On Error Resume Next
Application.OnTime EarliestTime:=dtNextTime, Procedure:="PlanNextTime", Schedule:=False
On Error GoTo 0
Application.StatusBar = False
End Sub
Sub CloseWorkbook()
' In my real workbook, at this place I call a sub to do some final things like saving the workbook
Application.StatusBar = False
ThisWorkbook.Close
End Sub
To test this, I used only the last minute. Then I found out I get strange problems with other manually started procedures. My preliminary conclusion: you can't run a manually started procedure together the a procedure started with the Application.OnTime command. I think I can find a workaround, but I want to be sure my conclusion is right. Excel VBA should be single-threaded, so I'm not sure my conclusion is right.
Therefore my question to you: is someone familiar with problems with procedures fired with the Application.OnTime command, fired on the same time a manual started procedure is running?
Do you know any way to deal with this issue?
I think your issue is that the Event you've created doesn't fire when an existing routine is running. That would be correct for the reason you surmised: Excel VBA is single-threaded.
Perhaps your 'manually started' procedure is amending records in a large table for instance or similar? If that's the case, insert a DoEvents into your loops to allow any pending events scheduled to be fired. This will cause the running to jump to your scheduled subroutine (PlanNextTime()) and complete that before returning to your loop.
I can't see much wrong with your posted code, though I confess I've not gone through it entirely to check your clever but confusing minutes vs seconds handling. I did notice however that you don't appear to be calling StopCountDownTimer() within your CloseWorkbook(). This will likely mean that on closing the workbook, or even Excel entirely, Excel will re-open the Workbook after closing to run your next scheduled event.
I'm trying to come up with a way to close an excel document after a period of inactivity. The problem i'm running into is that if excel is in Edit mode, the macro will not execute. This would be for a workbook that is on a server that multiple people have access to, the problem is that some people leave it open and forget that they have it open and no one else can edit it hence the need for this.
I've create a VBA macro code that only closes the excel document while the user is not in edit mode:
Sub OpenUp()
Dim Start, Finish, TotalTime, TotalTimeInMinutes, TimeInMinutes
Application.DisplayAlerts = True
TimeInMinutes = 1 ' sets timer for 1 minutes
If TimeInMinutes > 1 Then
TotalTimeInMinutes = (TimeInMinutes * 60) - (1 * 60)
' times 60 seconds to "minutize"/convert time from seconds to minutes
Start = Timer ' Sets the start time.
Do While Timer < Start + TotalTimeInMinutes
DoEvents ' Yield to other Excel processes.
Loop
Finish = Timer ' Set end time.
TotalTime = Finish - Start ' Calculate total time.
Application.DisplayAlerts = False
MsgBox "You've had this file open for " & TotalTime / 60 & " minutes. You have 1 minute to save all your files before Excel closes"
End If
Start = Timer ' Sets the start time.
Do While Timer < Start + (1 * 60)
DoEvents ' Yield to other Excel processes.
Loop
Finish = Timer ' Set end time.
TotalTime = Finish - Start ' Calculate total time.
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.Quit
End Sub
I know this request kind of defies logic as you don't want the workbook to close while someone is in the middle of a edit hence why you can't run a macro while in edit mode. But if there is any way to set up some code to save and close a workbook after a certain set time period has passed i would have need of it in this circumstance. Thanks
You need place the below code and save the file to XLSM type. Reopen the file to run the macro
Place the code in the standard module
Option Explicit
Public EndTime
Sub RunTime()
Application.OnTime _
EarliestTime:=EndTime, _
Procedure:="CloseWB", _
Schedule:=True
End Sub
Sub CloseWB()
Application.DisplayAlerts = False
With ThisWorkbook
.Save
.Close
End With
End Sub
Place the code in the Thisworkbook Module
Option Explicit
Private Sub Workbook_Open()
EndTime = Now + TimeValue("00:00:20") '~~> 20 Seconds
RunTime
End Sub
Place this in each worksheet to detect any changes in the worksheet
Private Sub Worksheet_Change(ByVal Target As Range)
If EndTime Then
Application.OnTime _
EarliestTime:=EndTime, _
Procedure:="CloseWB", _
Schedule:=False
EndTime = Empty
End If
EndTime = Now + TimeValue("00:00:20") '~~> 20 Seconds
RunTime
End Sub
I have got the answer from this site
http://www.excelforum.com/excel-programming-vba-macros/600241-excel-vba-close-workbook-after-inactivity.html
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?)