So this question is two parts. The first is seeing whether there is a quick and simple code that I can incorporate into my current sub to check how fast the sub will take to run. I just need precision down to seconds, and up to maybe a couple of minutes.
The 2nd is I am currently trying to optimize the run time of my sub. It is a search function that allows a user to specify which variables to select to search for and displays the results on the following worksheet. I've surfed the net and I've done the following general applications to speed up my program
disable screen updating at the beginning of my sub
avoid copy&paste to clipboard as much as possible
However, my program still takes ~5 to 10 seconds to run everytime the user runs a search. I would like to decrease this time as much as possible.
I realize without looking at my code it is hard to give specific suggestions, but I am currently just looking for general suggestions. If it is still slow after the general principles have been implemented I will post my code here.
My search program is a linear search program and stores the values into an array. My search function can accomodate up to 4 search variables though and I store each search into an array and I consolidate the array at the end into a final results array.
I generally use the GetTickCount API function. As long as you're not intending to measure time over weeks or months it should be accurate. Below is an example that shows different looping measures being timed. 1 tick = 1ms
Private Declare Function GetTickCount Lib "kernel32" () As Long
Sub test()
Dim nTime
nTime = GetTickCount
Set load_array = Range("a5:z65000")
array_index = WorksheetFunction.Match("Test 15", WorksheetFunction.Index(load_array, 0, 1), 0)
rngtimer = GetTickCount - nTime
nTime = GetTickCount
load_array = Range("a5:z65000").Value
array_index = WorksheetFunction.Match("Test 15", WorksheetFunction.Index(load_array, 0, 1), 0)
arraytimer = GetTickCount - nTime
nTime = GetTickCount
load_array = Range("a5:z65000").Value
For a = LBound(load_array) To UBound(load_array)
If load_array(a, 1) = "Test 15" Then
array_index = a
End If
Next
arraylooptimer = GetTickCount - nTime
nTime = GetTickCount
For a = 1 To 65000
If Range("a5").Offset(a, 0) = "Test 15" Then
array_index = a
End If
Next
excelooptimer = GetTickCount - nTime
MsgBox ("Range Search: " & rngtimer & vbCrLf & _
"Array Search: " & arraytimer & vbCrLf & _
"ArrayLoop Search: " & arraylooptimer & vbCrLf & _
"ExcelLoop Search: " & excelooptimer)
End Sub
Related
This is what my sheet looks like:
(I got the code from online somewhere & just been adjust what I know)
I Currently have 10 rows with working buttons, but it's already at 500+ lines of code and I still need 60more. I'm worried the file will become too large and start crashing.
Should I just keep changing the "Range(F#)" every time I make a new button/row?
Also, is it possible to keep more than 1 timer going at a time? Currently when I click stop on any of the rows it will stop whatever timer is active.
Public StopIt As Boolean
Public ResetIt As Boolean
Public LastTime
Private Sub cust10reset_Click()
Range("F10").Value = Format(0, "00") & ":" & Format(0, "00") & ":" & Format(0, "00") & "." & Format(0, "00")
LastTime = 0
ResetIt = True
End Sub
Private Sub cust10start_Click()
Dim StartTime, FinishTime, TotalTime, PauseTime
StopIt = False
ResetIt = False
If Range("F10") = 0 Then
StartTime = Timer
PauseTime = 0
LastTime = 0
Else
StartTime = 0
PauseTime = Timer
End If
StartIt:
DoEvents
If StopIt = True Then
LastTime = TotalTime
Exit Sub
Else
FinishTime = Timer
TotalTime = FinishTime - StartTime + LastTime - PauseTime
TTime = TotalTime * 100
HM = TTime Mod 100
TTime = TTime \ 100
hh = TTime \ 3600
TTime = TTime Mod 3600
MM = TTime \ 60
SS = TTime Mod 60
Range("F10").Value = Format(hh, "00") & ":" & Format(MM, "00") & ":" & Format(SS, "00") & "." & Format(HM, "00")
If ResetIt = True Then
Range("F10") = Format(0, "00") & ":" & Format(0, "00") & ":" & Format(0, "00") & "." & Format(0, "00")
LastTime = 0
PauseTime = 0
End
End If
GoTo StartIt
End If
End Sub
Private Sub cust10stop_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
StopIt = True
End Sub
I tried making a dedicated formula tab and just make macros going my timer buttons but I couldn't get that to work.
I tried making a togglebutton and linking it to the cell then just make a code that references the linkedcell to know where to put the timer, but that wasn't working. It just kept coming back true/false.
I guess I just want to know if it's ok to have 4000+ lines on 1 sheet with 210 buttons lol.
Or just an easier way.
Here's one approach using hyperlinks in place of buttons:
The hyperlinks you create need to have a destination, but in this case we want "do nothing" links - their only purpose is to trigger the sheet's FollowHyperlink event
This post
excel hyperlink to nothing
has suggestion for approaches to a "do nothing" hyperlink. Entering #rc for the address seems to work well - as explained by lori_m in their comment -
The # signifies a reference within a document and any formula that
returns a reference can follow in either A1 or r1c1 notation. Here rc
means this cell in r1c1notation.
Set up some links using "Insert >> Hyperlink", using "#rc" as the link target (entered next to "Address").
Don't use the HYPERLINK() formula, because those types of links don't trigger the FollowHyperlink event.
For example (3 timers running):
Finally this code goes in the worksheet code module:
Option Explicit
Dim timers As Object 'cell addresses as keys and start times as values
Dim nextTime 'next run time
'This is called when youclickon a hyperlink
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Dim txt As String, cLnk As Range, cTimer As Range, addr As String
Dim currVal
If timers Is Nothing Then Set timers = CreateObject("scripting.dictionary")
Set cLnk = Target.Range 'cell with clicked link
Set cTimer = cLnk.EntireRow.Columns("B") 'cell with elapsed time
addr = cTimer.Address(False, False) 'address of cell with elapsed time
txt = Target.TextToDisplay 'Start/Stop/Reset
Select Case txt 'what action to take depends on the link's text
Case "Stop"
If timers.Exists(addr) Then timers.Remove addr
Target.TextToDisplay = "Start" 'toggle link text
cLnk.Interior.Color = vbGreen 'toggle cell color
Case "Start"
currVal = cTimer.Value 'already some elapsed value?
timers(addr) = IIf(Len(currVal) > 0, Now - currVal, Now)
Target.TextToDisplay = "Stop"
cLnk.Interior.Color = vbRed
Case "Reset"
If timers.Exists(addr) Then 'timer is running?
timers(addr) = Now 'just reset the start time
Else
cTimer.Value = 0 'clear the elapsed time
End If
End Select
UpdateTimers
End Sub
'called using OnTime, or from the event handler
Sub UpdateTimers()
Dim addr As String, k, macro
macro = Me.CodeName & ".UpdateTimers"
On Error Resume Next 'cancel any running timer
Application.OnTime EarliestTime:=nextTime, Procedure:=macro, Schedule:=False
On Error GoTo 0
If timers.Count = 0 Then Exit Sub 'no more timers
For Each k In timers 'update timer(s)
Me.Range(k).Value = Format(Now - timers(k), "hh:mm:ss")
Next k
nextTime = Now + TimeSerial(0, 0, 1) 'schedule next run
Application.OnTime nextTime, macro
End Sub
What you could consider is to work with a Class module and a dictionary.
The Timer() command in XL merely generates a TimeStamp value that you can store for later use. You could do that in a dictionary with a particular class.
Create a Class module and name it cTimer add below code
Option Explicit
Private pTimer As Single
Public Sub StartTimer()
pTimer = Timer()
End Sub
Property Get Elapsed() As Single
Elapsed = Timer() - pTimer
End Property
Now, mind you, the portion of using the class may not strictly be required as you could simply add a dictionary entry for the address and Timer() value.
like so:
dict.Add Key, Timer()
But working with a class object allows you to create more functionality for each of the cTimer objects.
Now, to keep track of all the timers you can set add a new cTimer object to the dictionary based on the cell address of the button (this may need some fine tuning to ensure all your buttons eventually generate the same reference key)
But that is the most important portion of it, the reference key.
In a code module, add the below, this will look for an existing entry in the dictionary and if it exists display the elapsed time otherwise a new cTimer object will be added to the dictionary with the address as the reference key.
Create a Module and add the following:
Global dict As Object 'this line should be all the way at the top of the module code!
Sub TestTimer()
Dim rngButton As Range
Dim mm As cTimer
If dict Is Nothing Then
Set dict = CreateObject("Scripting.Dictionary")
End If
Caller = Application.Caller
Set rngButton = ActiveSheet.Buttons(Caller).TopLeftCell
Key = rngButton.Address
Set tmr = New cTimer
tmr.StartTimer
If Not dict.Exists(Key) Then
dict.Add Key, tmr
Else
Set tmr = dict(Key)
Debug.Print tmr.Elapsed
End If
End Sub
This may obviously need some tweaking to suit your particular need, but this could well be the solution you aim for. As you can simply have all the buttons refer to the same Method (or Macro)
You should add some logic for removing times and for resetting them etc. but the concept works.
see also: https://learn.microsoft.com/en-us/office/vba/Language/Reference/User-Interface-Help/dictionary-object
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
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!
I have a simple SUB within an Excel VBA module that runs almost instantly and gives control back to the user with no noticeable delay - but only when I run the sub from Excel's Alt-F8 list of public subs.
When I run the same sub by launching it from a button or shape then it still runs almost instantly BUT on finishing takes about 3 seconds to give control back to the user. The Windows busy circle icon displays on the screen during this pause and Excel does not respond to any key presses.
So, why can launchng a sub from a button be so different to launching from Alt-F8?
(I know that the sub itself runs very quickly as I have tested it with a Timer wrapper which confirms that the actual code runs in less than 0.1 seconds)
The code is shown here, but I would've thought this almost irrelevant as the same code is being run but just being launched by different means.
Public Sub RefDel()
IX = ActiveCell.Row: IY = ActiveCell.Column
If Cells(IX, 2) = "R" And (IY = PlnNor Or IY = PlnRef) Then
II = MsgBox("Remove Reference?", 292, Cells(IX, PlnRef))
If II = vbYes Then
ProtOff
NOF = Cells(IX, PlnNor)
Rows(IX & ":" & IX + NRoRef - 1).Delete Shift:=xlUp
Do While Cells(IX, 2) = "R" ' Renumber subsequent rows
Cells(IX, PlnNor) = NOF
NOF = NOF + 1
IX = IX + NRoRef
Loop
Cells(IX - NRoRef, PlnRef).Select
ProtOn
End If
Else
MsgBox "Select a Reference", vbCritical, "Delete Reference"
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