I want to start the vba macro to start to run every 45th second, If it got delayed then it has to start again at either at that minute 45th second or next minute 45th second and so on.. I wrote following 2 codes, but its not working. please guide
If Format(Now(), "ss") > 45 And Format(Now(), "ss") < 60 Then
runtime = Now()
Else
x = Format(Now(), "ss")
y = 45 - x
runtime = Now() + TimeValue("00:00:" & y)
End If
Application.OnTime runtime, "testtimer"
or (in the below code getting type mismatch here)
runtime = Now() + TimeValue("00:00:45")
nextime = runtime + TimeValue("00:00:45")
Application.OnTime runtime, "testtimer",nextime
Working with the application.onTime event is always a bit tricky. The following code should do what you are after.
Sub macro_to_run()
Debug.Print "at macro_to_run", Now
End Sub
Sub timed_procedure()
' read the position of the second hand from the syetem clock
Dim secondHand As Byte
secondHand = Second(Now)
' schedule this proc to run again either on the 45th second of this minute (if that is in the future)
' or the 45th second of the next minute
If secondHand < 45 Then
Application.OnTime DateAdd("s", 45 + Minute(Now) * 60 + Hour(Now) * 3600, Date), "timed_procedure"
Else
Application.OnTime DateAdd("s", 60 + 45 + Minute(Now) * 60 + Hour(Now) * 3600, Date), "timed_procedure"
End If
'execute the macro only if the current second is in the allowed window
If secondHand >= 45 And secondHand <= 50 Then
macro_to_run
End If
End Sub
Related
I have seen some strange behavior for VBA Timer function which suggests it can have sudden changes in output of up to 250 milliseconds, and I would like to understand this since I use it often in my VBA code. Is this even possible? Pls note that this is my first post to StackOverflow and I am not a professional programmer.
My research of timers says TIMER returns the number of fractional seconds since midnight, updated every few milliseconds depending on your PC environment. So for a period of a few milliseconds it returns the same value, and then jumps to the next value when it is reset to current seconds past midnight. I created a test code using QueryPerformanceFrequency and QueryPerformanceCounter (QPFC) to compare time intervals measured by TIMER and QPFC to better understand this behavious.
My code sets a start time using TIMER and QPFC and runs a loop to look at the difference in elapsed milliseconds from the start time. Much to my surprise I see the occasional huge jumps in TIMER time. The first image shows multiple jumps, max about 300mSec, when my Gigabyte Aero is running on battery but I see similar behavior when plugged in, and on my Surface Pro 4.
Image of output from Code:
[1]: https://i.stack.imgur.com/kDDuQ.png
The output shows that for my machine often there is 7.8 mSec update period for Timer as you can see in column A. I have seen many different multiples of 7.8 (mostly 7.8/N values, mostly I see 3.9mSec). But suddenly there can be a big jump in difference in elapsed time between the two timers that persists until the next jump in timer differences. Sometimes it takes several hours of looping to see the jump, but often I see it in less than a minute. I have run the same code on another multicore PC and see the same feature. Spikes in the difference in timers I can understand (PC gets busy elsewhere between timer calls) but not these steps. It runs until there is a preselected delta between timers, or end of the allow run time if there are no large steps.
The test code is at the end of this question, it needs a workbook open with a worksheet called “Timer”, and will populate the sheet with the headings, data, analysis, graph shown above to facilitate review. I “read” the TIMER before and after the QPFC timer to help diagnose the issue. Obviously if the PC decides that other activity is higher priority than this test code between the two TIMER queries, the difference between the two can take a big jump for one loop, but then should go back to the usual range of deltas between the two measured elapsed times. I.e. a spike in timer difference, not a permanent timer difference. The timing information suggests it is TIMER that is jumping not QPFC.
I added a check on how long the two timer calls take, TIMER is about 60 nSec, QPFC is about 900 nSec on my machine. I turned off time resets in Date and Time settings (not in VBA but in Windows). I see the jumps even if I use Task Manager to set the Excel affinity to one CPU.
Is my test code OK? Am I interpreting the data correctly? How can “time since midnight” change like this?
Option Explicit
Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As LongLong) As Long
Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LongLong) As Long
Private ll_Counter As LongLong
Private dFrequency As Double
'just put all variables where they can be used throughout module, not good practice but makes this test code easy to write
Dim dTimer1 As Double, dTimer2 As Double, dMaxDelta As Double, dLL_TimerDelta As Double, dTotalTime As Double
Dim dTimerStart As Double, dLL_TimerStart As Double, dTimer1Delta As Double, dTimer2Delta As Double, dMaxMinutes As Double
Dim iRow As Long, idTimerNothing As Long, iNothing As Long
Dim iLoops As Long, iReUse As Long
Sub Test_LongLongTimer() 'needs an open workbook with sheet names "Timer"
Application.ScreenUpdating = False
Application.Calculation = xlManual
Worksheets("Timer").Select
SetUpWorksheet
Call SetFrequency 'set the frequency for QPFC timer
dTotalTime = 0#
dMaxDelta = 0#
dTimerStart = Timer
dLL_TimerStart = LL_Timer
dMaxMinutes = 5#
Do While dMaxDelta < 10 And dTotalTime < (dMaxMinutes * 60# * 1000#) 'stops the loop when the TIMER to QPFC timer difference exceeds dMaxDelta or time is longer than dMaxMinutes
iRow = 2
iLoops = 10000
For iReUse = 2 To iLoops + 1 'allow for header row in top row when saving data, saves every 100th calc
'read timers
dTimer1Delta = (Timer - dTimerStart) * 1000# 'convert to milliseconds
dLL_TimerDelta = (LL_Timer - dLL_TimerStart) * 1000# 'convert to milliseconds
dTimer2Delta = (Timer - dTimerStart) * 1000# 'convert to milliseconds
SaveTimers 'save timers and analysis functions
For iNothing = 1 To 1 'add some extra delay before next comparisons to vary total time, change value as desired
DoEvents
Next iNothing
Worksheets("Timer").Range("A" & iRow & ":K" & iRow).Calculate
If Abs(Worksheets("Timer").Range("I" & iRow).Value) > dMaxDelta Then dMaxDelta = Abs(Worksheets("Timer").Range("I" & iRow).Value)
dTotalTime = dTimer2Delta
iRow = iRow + 1
Next iReUse
Application.Calculate
iRow = 2
Loop
'check time for LL_Timer function call, my system gives about 900 nanoseconds
dTimerStart = Timer
iLoops = 1000000
For iReUse = 1 To iLoops
dLL_TimerStart = LL_Timer
Next iReUse
dTimerStart = ((Timer - dTimerStart) / iLoops) * 1000000000# 'convert to NanoSeconds
Worksheets("Timer").Range("P1").Value2 = "MY TIMER Avrg NanoSeconds per LL_Timer call"
Worksheets("Timer").Range("P2").Value2 = dTimerStart
'check time for VBA timer function call, my system gives about 65 nanoseconds
dTimerStart = Timer
iLoops = 1000000
For iReUse = 1 To iLoops
dLL_TimerStart = Timer
Next iReUse
dTimerStart = ((Timer - dTimerStart) / iLoops) * 1000000000# 'convert to NanoSeconds
Worksheets("Timer").Range("P3").Value2 = "VBA TIMER Avrg NanoSeconds per Timer call"
Worksheets("Timer").Range("P4").Value2 = dTimerStart
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Worksheets("Timer").Range("p:p").ColumnWidth = 50
With Worksheets("Timer").Range("A:P")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.EntireColumn.AutoFit
.NumberFormat = "#,##0.0_);[Red](#,##0.0)"
End With
Call AddChart
End Sub
Function LL_Timer() 'Seconds
QueryPerformanceCounter ll_Counter
LL_Timer = CDbl(ll_Counter) / dFrequency
End Function
Private Sub SetFrequency()
Dim PerfFrequency As LongLong
QueryPerformanceFrequency PerfFrequency
dFrequency = CDbl(PerfFrequency)
End Sub
Sub AddChart()
Dim ChtObj As ChartObject
For Each ChtObj In Worksheets("Timer").ChartObjects
ChtObj.Delete
Next ChtObj
Range("H3").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Shapes.AddChart2(332, xlLineMarkers).Select
'ActiveChart.SetSourceData Source:=Range("Timer!$C$2:$C$1001")
ActiveChart.Parent.Name = "TimerDelta"
With ActiveChart.Parent
.Width = 15 * 72 '500 ' resize 72 pnts per inch
.Height = 3 * 72 '500 ' resize 72 pnts per inch
.Top = 105 ' reposition
.Left = 125 'reposition
End With
Dim ax As Axis
With ActiveChart.Axes(xlValue)
.TickLabels.Font.Size = 16
.TickLabels.Font.Bold = True
.Crosses = xlMaximum
End With
With ActiveChart.Axes(xlCategory)
.TickLabels.Font.Size = 16
.TickLabels.Font.Bold = True
End With
Range("C2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlUp)).Select 'funny stuff re bad display, fix by moving around
Range("C25").Select
End Sub
Sub SetUpWorksheet()
Worksheets("Timer").Range("A2:K1000000").ClearContents
Worksheets("Timer").Range("A1").Value2 = "dTimer1 (mSec)"
Worksheets("Timer").Range("B1").Value2 = "dMyTimer (mSEC)"
Worksheets("Timer").Range("C1").Value2 = "dTimer2 (mSEC)"
Worksheets("Timer").Range("D1").Value2 = "Delta, Timer1 to previous"
Worksheets("Timer").Range("E1").Value2 = "Delta, dMyTimer to previous, mSec"
Worksheets("Timer").Range("F1").Value2 = "Delta, Timer2 to previous"
Worksheets("Timer").Range("G1").Value2 = "Delta, Timer2 to dMyTimer"
Worksheets("Timer").Range("H1").Value2 = "Delta, dMyTimer to Timer1"
Worksheets("Timer").Range("I1").Value2 = "Delta of LL-T1 delta to previous delta" 'delta of column H
Worksheets("Timer").Range("J1").Value2 = "QueryPerformanceCounter"
Worksheets("Timer").Range("K1").Value2 = "QueryPerformanceCounter Delta To Previous"
End Sub
Sub SaveTimers()
Worksheets("Timer").Range("A" & iRow).Value = dTimer1Delta
Worksheets("Timer").Range("B" & iRow).Value = dLL_TimerDelta
Worksheets("Timer").Range("C" & iRow).Value2 = dTimer2Delta
Worksheets("Timer").Range("J" & iRow).Formula = ll_Counter
If iRow > 2 Then
Worksheets("Timer").Range("D" & iRow).Value = "=(A" & iRow & "-A" & (iRow - 1) & ")"
Worksheets("Timer").Range("E" & iRow).Value = "=(B" & iRow & "-B" & (iRow - 1) & ")"
Worksheets("Timer").Range("F" & iRow).Value = "=(C" & iRow & "-C" & (iRow - 1) & ")"
Worksheets("Timer").Range("G" & iRow).Value = "=(C" & iRow & "-B" & iRow & ")"
Worksheets("Timer").Range("H" & iRow).Value = "=(B" & iRow & "-A" & iRow & ")"
Worksheets("Timer").Range("I" & iRow).Value = "=(H" & iRow & "-H" & (iRow - 1) & ")"
Worksheets("Timer").Range("K" & iRow).Value = "=(J" & iRow & "-J" & (iRow - 1) & ")"
End If
End Sub
Original
I have the following code that is coloring a cell to demonstrate the use of milisecond wait time. However, when i = 500 the code breaks. The error I get is Code Execution has been Interrupted and from 500 to 1000 I have to keep clicking continue. I've tried to wrap my code in an Application.DisplayAlerts = False and True but it still gets interrupted and won't finish. I estimate this code will take approximately 6 minutes more or less as i approaches 1000. I'm at a loss as to what could cause this. I've gone through every setting I can think of and it won't continue past 500 without breaking. ms was calculated from 1/(1000*24*60*60).
Excel 2007
Sub Kaleidoscope()
Dim r, g, b, i As Integer, ms As Double
ms = 0.0000000115741
For i = 1 To 1000
r = WorksheetFunction.RandBetween(1, 255)
g = WorksheetFunction.RandBetween(1, 255)
b = WorksheetFunction.RandBetween(1, 255)
Range("A1").Interior.Color = RGB(r, g, b)
Application.Wait (Now + (ms * i))
Next i
End Sub
Thank you in advance!
Update
The link provided by #MarcoMarc (stackoverflow.com/a/5823507/5175942) solved the initial breaking problem of my question. However, it still does not appear to be incrementing correctly. It goes as if it isn't waiting until i = 500 then appears to be stalling 1 second every time. Is this the limit you were speaking of and ultimately it is not possible to wait for 1 ms? No change in the original code was needed to prevent the breaking.
Final Thoughts
#JohnMuggins gives a great tweak to my original code and provides additional tools to see the calculations behinds the scenes. Ultimatley though, he also had to call winAPI like #MacroMarc in order to pause the code for less than 1 second. Through research on additional websites and through Stack Overflow, it appears not possible to pause the program for less than 1 second using VBA alone. It either runs at normal speed or when it gets to 500 ms it rounds up to 1 second and delays the code for 1 second instead of 500 ms. My final code for demonstration is below with #JohnMuggins tweaks.
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Kaleidascope()
Dim StartTime As Double
Dim EndTime As Double
Dim ms As Double
Dim i, r, g, b As Integer
Dim count As Long
StartTime = Timer
For i = 1 To 500
ms = i
r = WorksheetFunction.RandBetween(1, 255)
g = WorksheetFunction.RandBetween(1, 255)
b = WorksheetFunction.RandBetween(1, 255)
Range("A1").Interior.Color = RGB(r, g, b)
Sleep ms
Range("B1").Value = "Time: " & Format(Timer - StartTime, "####.###")
Range("C1").Value = "ms = " & Format(ms, "####.####")
Range("D1").Value = i & " of 500"
Next i
EndTime = Timer - StartTime
Debug.Print Format(EndTime, "####.##")
End Sub
You could use the Sleep function from winAPI.
At the top of the module:
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Then in your code:
Sleep i ' where i is now in milliseconds
Note that Sleep delays all VBA code.
0m3r was correct. The problem is with the application.wait function. Try the following do events routine instead.
Sub Kaleidoscope()
Dim r, g, b, i As Integer, ms As Double
ms = 0.0000000115741
For i = 1 To 1000
r = WorksheetFunction.RandBetween(1, 255)
g = WorksheetFunction.RandBetween(1, 255)
b = WorksheetFunction.RandBetween(1, 255)
Range("A1").Interior.Color = RGB(r, g, b)
Range("A1").Value = i
For j = Now To (Now + (ms * i))
DoEvents
Next j
Next i
End Sub
This is the only way I could reach your objective of run-time of 2 minutes and 9 seconds.
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
' run time on my computer 2:09:07
' runs from 6 ms to 751.5 ms
Sub ewhgfsd()
Dim StartTime As Double
Dim EndTime As Double
StartTime = Timer
For i = 1 To 500
ms = ms + (i * 0.006)
r = WorksheetFunction.RandBetween(1, 255)
g = WorksheetFunction.RandBetween(1, 255)
b = WorksheetFunction.RandBetween(1, 255)
Range("A1").Interior.Color = RGB(r, g, b)
Sleep ms
Range("B1").Value = "Time: " & Format(Timer - StartTime, "####.##")
Range("C1").Value = "ms = " & Format(ms, "####.#####")
Range("D1").Value = i & " of 500"
Next i
EndTime = Timer - StartTime
Debug.Print Format(EndTime, "####.##")
End Sub
I want to add wait time of 1 second in my Application.
What I found online?
newHour = Hour(Now())
newMinute = Minute(Now())
newSecond = Second(Now()) + 1
waitTime = TimeSerial(newHour, newMinute, newSecond)
Application.Wait waitTime
Here is my code
Sub workwithdelay()
Dim i As Integer
Dim done As Integer
Dim newHour As Integer
Dim newMinute As Integer
Dim newSecond As Integer
Dim waitTime As String
Dim ws As Worksheet
Set ws = ActiveSheet
frame = Cells(1, "A").Value
For i = 1 To done
newHour = Hour(Now)
newMinute = Minute(Now)
newSecond = second(Now) + 1
waitTime = newHour: newMinute: newSecond
(ALL of work Code)
Application.Wait waitTime
Next i
End Sub
The code takes 0.30 seconds to 0.45 seconds to complete one cycle in for loop(not including wait time) depending on the processing of data. I want to add a definite 1 second to complete one for loop cycle no matter what the processing time of the loop is.
You have the right idea, but I think what you want is the TimeValue function (documented here).
You can use it like this:
Dim StartTime as Date
Dim EndTime as Date
StartTime = Now
EndTime = StartTime + TimeValue("00:00:01")
' Do Stuff
Application.Wait EndTime
This will cause the application to wait until one second after the start of the Do Stuff section, which I think is what you are asking for.
Hope this helps :)
You need to use different technique with do...loop + timer.
Sub WaitOneSecond()
Dim Start as single
start = timer
do while start + 1 > timer
doevents
loop
end sub
and in your original sub call WaitOnSecond where necessary:
Sub workwithdelay()
(...)
For i = 1 To done
(...)
call WaitOnSecond
Next i
End Sub
Some information to above:
timer counts seconds and milliseconds from midnights of today
be careful with my code run just before midnight- it is not correct when new day starts
application.wait doesn't recognise milliseconds therefore you are not able to get exact 1 second waiting time
I have a program that uses a VBA countdown timer.
I can only enter minutes. How can I enter seconds?
In Module1 I enter the time
Public Const AllowedTime As Double = 1
and the code looks like this
Private Sub CommandButton1_Click()
Dim T, E, M As Double, S As Double
T = Timer
Do
E = CDbl(Time) * 24 * 60 * 60 - T
M = AllowedTime - 1 - Int(E / 60)
S = 59 - Round((E / 60 - Int(E / 60)) * 60, 0)
With tBx1
.Value = Format(CStr(M), "00") & ":" & Format(CStr(S), "00")
End With
DoEvents
Loop Until (Timer - T) / 60 >= AllowedTime
End Sub
Private Sub poker_Initialize()
Dim M As Double, S As Double
M = Int(AllowedTime)
S = (AllowedTime - Int(AllowedTime)) * 60
With tBx1
.Value = Format(CStr(M), "00") & ":" & Format(CStr(S), "00")
End With
End Sub
Here is a simple working example
https://app.box.com/s/211uo88dk02x6il8hqj19wyiv1rli2sj
I suggest that you use Date variables for your time calculations because it is much easier.
You will also need a module-level variable if you want the Pause button to work. This code lets you show minutes & seconds. Your AllowedTime variable should be minutes with a decimal part for seconds, or change it to the number of seconds and change the lines that are commented out.
Dim userClickedPause As Boolean ' Gets set to True by the Pause button
Private Sub CommandButton1_Click()
Dim stopTime As Date
userClickedPause = False
' If AllowedTime is the number of minutes with a decimal part:
stopTime = DateAdd("s", Int(AllowedTime * 60), Now) ' add seconds to current time
' If AllowedTime is the number of seconds:
'stopTime = DateAdd("s", AllowedTime, Now) ' add seconds to current time
Do
With tBx1
.Value = Format(stopTime - Now, "Nn:Ss")
End With
DoEvents
If userClickedPause = True Then
Exit Do
End If
Loop Until Now >= stopTime
End Sub
Private Sub CommandButton2_Click()
userClickedPause = True
End Sub
for a project of mine i am trying to produce a macro in VBA the purpose of the GOTO statement is to repeat the Do while loop until it is forced to stop.
every time i try to run the program VBA for applications freezes and no error seems to be apparent can anybody suggest why this might be happening and if there are any fixes
Sub buses()
test.Caption = Day
Dim mytime As String 'intiger showing current time
mytime = "string" ' testing perpus only
Dim counter As Integer 'intiger value for counter
counter = 1 'counter set at 0
Dim record As Integer 'intiger value for record
Jump
Do While counter < 20 'repeat if statment untill counter reaches 20
counter = counter + 1 ' upon repeating counter has increased by 1
If mytime = CStr(ThisWorkbook.Sheets("mon A").Range("A" & counter).Value) Then
'if current time = a time of due to arive bus then
record = counter 'record value and counter value are the same
V1F1.Caption = CStr(ThisWorkbook.Sheets(Day).Range("A" & record).Value) 'display record information on screen
V1F2.Caption = CStr(ThisWorkbook.Sheets(Day).Range("B" & record).Value)
V1F3.Caption = CStr(ThisWorkbook.Sheets(Day).Range("C" & record).Value)
record = record + 1
V2F1.Caption = CStr(ThisWorkbook.Sheets(Day).Range("A" & record).Value) 'display record information on screen
V2F2.Caption = CStr(ThisWorkbook.Sheets(Day).Range("B" & record).Value)
V2F3.Caption = CStr(ThisWorkbook.Sheets(Day).Range("C" & record).Value)
record = record + 1
V3F1.Caption = CStr(ThisWorkbook.Sheets(Day).Range("A" & record).Value) 'display record information on screen
V3F2.Caption = CStr(ThisWorkbook.Sheets(Day).Range("B" & record).Value)
V3F3.Caption = CStr(ThisWorkbook.Sheets(Day).Range("C" & record).Value)
Exit Do 'break do
End If 'end if statment
Application.Wait DateAdd("s", 1, Now) 'wait 1 second
Loop ' loop as a result of if stament not being executed
GoTo Jump: 'repeat Do while
End Sub
How about moving counter = 1 after "Jump". Next time use a for loop.