I am writing a code to copy data from one spreadsheet to an other one in every second. I have tried Application.Wait and Sleep but they blocked both spreadsheets so I decided to use a do until loop. It works but 1 sec lasts almost 2 sec and I don't know why. So I left only the loop in the code but the test gave the same result (it took ca 95 sec). Any suggestion? Here is the code:
Sub Test()
Dim Delay As Date
cell = 1
For i = 1 to 60
Workbooks("Data").Worksheets("Sheet1").Range("C" & cell).Value = cell
cell = cell +1
Delay = Now() + TimeValue("00:00:01")
Do Until Now() >= Delay
Do Events
Loop
Next i
End Sub
That is only an approximate delay because you really have no idea of what else is going through the message queue and being processed by the DoEvents command (one word btw). An alternative would be to call the procedure from within itself with the Application.OnTime method.
Sub timed_routine()
Application.Interactive = False
ThisWorkbook.Worksheets("Sheet1").Cells(1, 1) = 1
Application.Interactive = True
'Debug.Print Timer
Application.OnTime Now + TimeSerial(0, 0, 1), "timed_routine"
End Sub
With the Debug.Print Timer command uncommented and active, this routine was cycling in about 1.015 seconds.
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
I read a data line from an instrument using Excel VBA.
I would like to plot the data dynamically on an Excel Active Chart, IMMEDIATELY after it has been read.
I need to wait and read the data every 5 seconds and, in the mean time, I "sleep", either through the VBA Application.Wait command, or through the Kernel32 Sleep command.
In either case the Active Chart does NOT get updated. The complete plot shows up only after the LAST "sleep".
Any suggestions will be appreciated.
Here is the simplified code
Sub New_Data(indx)
Dim x As Integer
While True
x = Read_Instrument(1)
y = Read_Instrument(2)
Cells(indx, 1) = x
Cells(indx, 2) = y
ActiveSheet.ChartObjects.Item(1).Activate
ActiveChart.FullSeriesCollection(1).XValues = "=Sheet1!$A$1:$A$" & indx
ActiveChart.FullSeriesCollection(1).Values = "=Sheet1!$B$1:$B$" & indx
indx = indx + 1
Sleep 5000 'Use the KERNEL32 Sleep function for 5000 milliseconds
Wend
End Sub
Wait and Sleep will keep VBA running, so the screen will not updated.
Try using Application.OnTime, along these lines (in a standard code module, i.e. Module1).
Sub refreshMyChart()
Dim indx as long: indx = sheet1.Cells(Rows.Count, 1).End(xlUp).offset(1)
Cells(indx, 1) = Read_Instrument(1)
Cells(indx, 2) = Read_Instrument(2)
With Sheet1.ChartObjects(1).FullSeriesCollection(1)
.XValues = "=Sheet1!$A$1:$A$" & indx
.Values = "=Sheet1!$B$1:$B$" & indx
End With
''''' Now Schedule the same routine for 5 seconds later''''''''''
Application.OnTime Now + TimeSerial(0,0,5), "refreshMyChart"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End Sub
p.s.: be aware that this data cannot grow indefinitely.. You should define some way to stop or to delete old rows to keep the number of displayed data rows reasonable.
Excellent! Thank you very much.
I was not aware of the .OnTime construct
Application.OnTime Now + TimeSerial(0, 0, 5), "refreshMyChart"
and the fact that VBA allows recursive routines.
As for ending the loop, there is code in there, which I did not post because it was not relevant to the issue. Here it is
If Int(current_index / nmeasure) * nmeasure > finalval Then
MsgBox ("End of Measurement")
Exit Sub
End If
Thanks again.
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 am trying to write a program that runs indefinitely, till I stop it. For some reason it exited this while loop early (after 6 hours). A co-worker thinks it is because an error in the cpu, and I should use a Boolean flag instead of a string (less chance for the error). Is there any other suggestions?
If CommandButton1.Caption = "Start" Then
CommandButton1.Caption = "Stop"
Else
CommandButton1.Caption = "Start"
End If
While CommandButton1.Caption = "Stop"
pause 1
Range("C1").Value = Range("C1").Value + 1
If Range("C1").Value = 300 Then
Range("C1").Value = 0
takeameasurement ' This function did not cause the problem
End If
Wend
(my pause function if you were wondering)
Function pause(time As Integer)
t = Timer + time 'wait for the table to settle before taking a measurement
Do While t > Timer
DoEvents
Loop
End Function
Timer returns the number of seconds since midnight, so you may run into a problem if you call your pause function just before Timer loops back to zero.
Imagine only 100 seconds in a day and you call pause when Timer = 99.5 - potentially you could end up with a value of t which is 100.5, in which case t > Timer will always be true and your Do loop never exits.
Function pause(time As Integer)
t = Timer + time
Do While t > Timer
DoEvents
Loop
End Function
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.