I have a large amount of data to scroll through every day and an autoscroll macro that pauses when a key is pressed (and resumes with a button push) would be a big help.
So far, I've tried:
Sub Autoscroll()
Dim RowCount As Integer
Dim i As Integer
RowCount = Range("Table").Rows.Count
For i = RowCount + 1 To 2 Step -1
Range("A" & i).Select
Application.Wait (Now + TimeValue("0:00:01"))
Next i
End Sub
But this doesn't achieve what I want for a few reasons:
It doesn't pause when I press a key
It can't go faster than 1 second. (I could use the Sleep function to make the scroll move faster)
Looking for some recommendations about the best way to do this.
Thank you
If you insist on using a macro try this, it should do the trick (if you are using Windows!).
You have to press the return key to interrupt. If you'd prefer a different key let me know.
Option Explicit
#If VBA7 Then
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#Else
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If
'Sub pausing code execution without freezing the app or causing high CPU usage
'Author: Guido Witt-Dörring, https://stackoverflow.com/a/74387976/12287457
Public Sub WaitSeconds(ByVal seconds As Single)
Const VK_RETURN = &HD
Dim currTime As Single, endTime As Single, cacheTime As Single
currTime = Timer(): endTime = currTime + seconds: cacheTime = currTime
Do While currTime < endTime
If GetAsyncKeyState(VK_RETURN) Then
Sleep 200
Do Until GetAsyncKeyState(VK_RETURN)
DoEvents: Sleep 15
Loop
Sleep 200
End If
DoEvents: Sleep 15: currTime = Timer()
'The following is necessary because the Timer() function resets at 00:00
If currTime < cacheTime Then endTime = endTime - 86400! 'seconds per day
cacheTime = currTime
Loop
End Sub
Sub Autoscroll()
Dim RowCount As Long
Dim i As Long
RowCount = Range("Table").Rows.Count
For i = RowCount + 1 To 2 Step -1
WaitSeconds 0.5 '<-- this is how long it waits at every row,
Range("A" & i).Select 'set it to your desired value
Next i
End Sub
I am looking for a solution to call a MySub every 100 milliseconds.
MySub contains a loop with a variable length (and variable execution time).
Currently I can do this every second with this code:
Sub UPDATECLOCK()
Call MySub
NextTick = Now + TimeValue("00:00:01")
Application.OnTime NextTick, "UPDATECLOCK"
End sub
I read in the first answer in this post that it is not possible:
VB Excel Macro Millisecond Timing
Although in the second answer this solution is given:
Sub Macro2()
' Macro2 Macro
Range("C1").FormulaR1C1 = "1"
Application.Wait (Now + TimeValue("0:00:01")) '1sec
Range("C1").FormulaR1C1 = "2"
Application.Wait (Now + 0.000001) '1/10sec
Range("C2").Select
Sleep (100)
End Sub
If I understand correctly Application.Wait is added to let Excel wait for several milliseconds.
https://learn.microsoft.com/en-us/office/vba/api/excel.application.wait
Although the Excel application is frozen while using Wait which is not feasible for me.
Maybe an alternative could be to measure the time my loop takes to execute on the system clock.
I found this website https://www.aeternus.sg/best-millisecond-timer-vba/ with this code:
' Performance counter API's
#If VBA7 And Win64 Then
'for 64-bit Excel
Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
#Else
'for 32-bit Excel
Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
#End If
'Purpose: Measure elapsed time in milliseconds
Sub TimeACode()
Dim curFrequency As Currency
Dim curStartPerformanceCounter As Currency
Dim curEndPerformanceCounter As Currency
Dim lgResult As Long
'obtain no: of counts per second
lgResult = QueryPerformanceFrequency(curFrequency)
If lgResult > 0 Then
Debug.Print "Frequency: " & curFrequency
End If
'measure start count
lgResult = QueryPerformanceCounter(curStartPerformanceCounter)
If lgResult > 0 Then
Debug.Print "Start Count: " & curStartPerformanceCounter
End If
'*****************************************
'Insert the code to measure elapsed time
'*****************************************
'measure end count
lgResult = QueryPerformanceCounter(curEndPerformanceCounter)
If lgResult > 0 Then
Debug.Print "End Count: " & curEndPerformanceCounter
End If
'measure elapsed time
Debug.Print "Elapsed time (ms): " & (curEndPerformanceCounter - curStartPerformanceCounter) / curFrequency
End Sub
I do not understand this code very well. Although it seems to me it counts the processor ticks since the last reboot of the system. Would it be possible to alter this code in a way that it will call MySub after a certain number of ticks of the processor?
If I call this function on my system:
lgResult = QueryPerformanceFrequency(curFrequency)
The function returns 1000.
Does this mean my processor makes 1000 ticks per second?
Would it be possible to call MySub after every 100 ticks?
Thanks a lot!
This question already has answers here:
There is no Wait Method associated with Application in VisualBasic Word
(4 answers)
Closed 3 years ago.
I would like to have a break where it randomly waits between 5-10 minutes before going to the next i.
Unfortunately the function Application.Wait does not work in Word.
Do you have another solution for me?
I don't know much about macros.
-
The Error is: Error during compilation:
Constants, character strings of fixed length, user-defined data fields and Declare statements are not permitted as public elements of object modules.
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Sub Test_DE()
If MsgBox("Wirklich senden?", vbYesNo, "Senden") <> vbYes Then Exit Sub
Application.ScreenUpdating = False
Dim i As Long
With ActiveDocument
For i = 1 To .MailMerge.DataSource.RecordCount
With .MailMerge
.Destination = wdSendToEmail
.MailSubject = "xxxx"
.MailFormat = wdMailFormatHTML
.MailAddressFieldName = "EMAIL"
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
End With
.Execute Pause:=False
End With
Delay = Int((600000 - 300000 + 1) * Rnd + 300)
Sleep (Delay)
'CreateObject("Excel.Application").Wait (Now + TimeValue("00:00:Delay"))
'Dim PauseDelay As Long
'PauseDelay = Int((600 - 300 + 1) * Rnd + 300) ' Stores the random interval between 300-480
'Call Pause(PauseDelay) ' Calls Pause with the random interval
Next i
End With
Application.ScreenUpdating = True
End Sub
If you work on Windows...
Open a normal module (in VBE press Alt+I, M) then place the code below at the beginning.
#If VBA7 And Win64 Then
' For 64bit version of Excel
Public Declare PtrSafe Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As LongPtr)
#Else
' For 32bit version of Excel
Public Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
#End If
Then you could use sleep 1000 to wait for one second.
I am trying to insert a pause into Excel VBA code. The following code generates a compile error: "Invalid Qualifier".
The function Pause() is trying to combine the Application.Wait method with DoEvents to get the best of both worlds; Excel will continue to process keystrokes and mouse clicks while not eating up CPU resources as it waits.
Background:
http://www.fmsinc.com/microsoftaccess/modules/examples/avoiddoevents.asp
http://www.cpearson.com/excel/WaitFunctions.aspx
http://vbadud.blogspot.com/2008/03/sleep-function-in-excel-vba.html
Public Declare Function GetTickCount Lib "kernel32" () As Long
' A DoEvents loop uses CPU power.
' Application.Wait suspends all keyboard and mouse actions.
' This function is a hybrid to combine the best of both worlds.
Public Sub Pause(Optional Timeout As Single = 5)
Dim EndTime
EndTime = GetEndTick(Timeout)
Do While GetTickCount() <= EndTime
DoEvents
Application.Wait DateAdd("s", 0.1, Now)
Loop
End Sub
' Timeout is in seconds.
Function GetEndTick(Timeout)
GetEndTick = GetTickCount() + Timeout * 1000
End Function
To answer my question for some reason the Application object is not being recognized. I used the following workaround successfully:
Worksheets.Application.Wait DateAdd("s", 0.1, Now)
However I have discovered that the Worksheets.Application.Wait takes up CPU resources which defeats the purpose. Instead here is a working Pause function:
#If VBA7 Then
' Insert PtrSafe for Excel 64 as per http://stackoverflow.com/a/5507370/2529619
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetTickCount Lib "kernel32" () As Long
#End If
' "Pause" code execution for "Timeout" seconds.
'
' Excel will continue to process the keyboard and mouse clicks at least once a second.
' This Pause function will not take up lots of CPU resources.
' 2015.02.04 -- Chaim Gewirtz
Public Sub Pause(Optional Timeout As Single = 5)
Dim EndTick
' There are 1000 'ticks' in a second.
EndTick = GetTickCount() + Timeout * 1000
Do While GetTickCount() <= EndTick
' Process keyboard and mouse events while waiting.
DoEvents
' If there is at least one more second to pause then...
If EndTick - GetTickCount() > 1000 Then
' "Wait" for one second without using CPU resources.
Sleep 1000
End If
Loop
End Sub
Visual Basic - all variations - use end of line as the end of statement marker. This contrasts with C# where semi-colon is used as a statement terminator, and with Delphi where semi-colon is used as a statement separator.
So, this line:
Application.Wait DateAdd("s", 0.1, Now)
is treated as a single statement, and it doesn't make sense. The best that the compiler can do is to think that you're wanting to use Application.Wait as a qualifier, but it doesn't understand it.
Change the code to this:
Application.Wait
DateAdd("s", 0.1, Now)
and it should at least execute. Though, whether it's good practice is another question.
I have a userform which runs a script every 100ms. The script handles images on the userform and is used to animate them, while the form continues to receive user input (mouse clicks and key presses). This continues until the userform is closed. While Application.OnTime seems to work best, it only operates consistently on time values of 1 second or more.
When I use something like
Sub StartTimer()
Application.OnTime now + (TimeValue("00:00:01") / 10), "Timer"
End Sub
Private Sub Timer()
TheUserForm.ScreenUpdate
Application.OnTime now + (TimeValue("00:00:01") / 10), "Timer"
End Sub
and call StartTimer in the userform, Excel becomes very unresponsive and "Timer" is called many more times per second than it should.
Using the Sleep function causes the program to become unresponsive too, although the script is run with the right interval.
Is there a workaround for this? Thanks in advance!
OnTime can only be scheduled to run in increments of 1 second. When you attempt to schedule it at 1/10th second, you actually schedule at 0 seconds, ie it runs again immediately, consuming all resources.
Short answer, you cannot use OnTime to run an event every 1/10 second.
There are other ways, see CPearson for using a call to Windows API
Public Declare Function SetTimer Lib "user32" ...
Try this simple hybrid method for your 'Timer' sub:
Sub Timer
Application.OnTime now + TimeValue("00:00:01"), "Timer"
t1 = Timer
Do Until Timer >= t1 + 0.9
t2 = Timer
Do Until Timer >= t2 + 0.1
DoEvents
Loop
TheUserForm.ScreenUpdate
... your code
Loop
End Sub
Of course, one problem of user the 'Timer' function is that at midnight your code may turn into a pumpkin (or crash). ;) You would need to make this smarter but if you generally only work during the day, like me, it's not a problem.
Just had this same question today. Here's the solution I was able to find that worked really well. It allows a timed event to fire on intervals as small as 1 millisecond, without taking control of the application or causing it to crash.
The one disadvantage I've been able to find is that TimerEvent() requires a blanket On Error Resume Next to ignore errors caused when it can't execute the code (like when you're editing another cell), which means it will have no idea when a legitimate error occurs.
Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, _
ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, _
ByVal nIDEvent As LongPtr) As Long
Public TimerID As Long
Sub StartTimer()
' Run TimerEvent every 100/1000s of a second
TimerID = SetTimer(0, 0, 100, AddressOf TimerEvent)
End Sub
Sub StopTimer()
KillTimer 0, TimerID
End Sub
Sub TimerEvent()
On Error Resume Next
Cells(1, 1).Value = Cells(1, 1).Value + 1
End Sub
' yes it is a problem
' it stops when cell input occurs or an cancel = false dblClick
' the timer API generally bombs out EXCEL on these
' or program errors as VBA has no control over them
' this seems to work and is in a format hopefully easy to adapt to
' many simultaneous timed JOBS even an Array of Jobs.. will try it this week
' Harry
Option Explicit
Public RunWhen#, PopIntervalDays#, StopTime#
Public GiveUpDays#, GiveUpWhen#, PopTimesec#, TotalRunSec!
Public PopCount&
Public Const cRunWhat = "DoJob" ' the name of the procedure to run
Sub SetTimerJ1(Optional Timesec! = 1.2, Optional RunForSec! = 10, Optional GiveUpSec! = 20)
If Timesec < 0.04 Then Timesec = 0.05
' does about 150 per sec at .05 "
' does 50 per sec at .6 ????????????
' does 4 per sec at .9 ????????????
'iterations per sec =185-200 * Timesec ( .1 < t < .9 )
' if t >1 as int(t)
' or set Timesec about (iterationsNeeded -185)/200
'
PopTimesec = Timesec
PopIntervalDays = PopTimesec / 86400# ' in days
StopTime = Now + RunForSec / 86400#
GiveUpDays = GiveUpSec / 86400#
TotalRunSec = 0
PopCount = 0
StartTimerDoJob
End Sub
Sub StartTimerDoJob()
RunWhen = Now + PopIntervalDays
GiveUpWhen = Now + GiveUpDays
Application.OnTime RunWhen, cRunWhat, GiveUpWhen
' Cells(2, 2) = Format(" At " & Now, "yyyy/mm/dd hh:mm:ss")
'Application.OnTime EarliestTime:=Now + PopTime, Procedure:=cRunWhat, _
Schedule:=True
End Sub
Sub DoJob()
DoEvents
PopCount = PopCount + 1
'Cells(8, 2) = PopCount
If Now >= StopTime - PopIntervalDays / 2 Then ' quit DoJob
On Error Resume Next
Application.OnTime RunWhen, cRunWhat, , False
Else
StartTimerDoJob ' do again
End If
End Sub
Sub StopTimerJ1()
On Error Resume Next
Application.OnTime EarliestTime:=RunWhen, Procedure:=cRunWhat, _
schedule:=False
End Sub