I see a lot of VBA code on this site using the Range method with For loops:
Range("A" & i)
As opposed to a proper Cells command:
Cells(i,1)
I always knew the Cells way was faster, partly because Range takes longer to resolve, and partly because concatenation (&) is a relatively slow process (as opposed to any other simple arithmetic operation - AFAIK).
So, the question is, is it really faster? By how much? Sometimes, the Range format is more readable, especially for newbies. Does the speed gain justify the slight discomfort and necessary extra explanation in replies?
I have done some testing to see what's what.
Method
I have tested the speeds of four scenarios. Each test consisted of a For loop doing 100 000 cycles. The core of the test was using a with statement to "grab" a cell.
For i = 1 To 100000
With Cells(i, 1)
End With
Next i
The four tests were:
Cells, variable cells - With Cells(i, 1)
Cells, single cell - With Cells(1, 1)
Range, variable cells - With Range("A" & i)
Range, single cell - Range("A1")
I have used separate subs for the four test cases, and used a fifth sub to run each of them 500 times. See the code below.
For time measurement, I have used GetTickCount to get millisecond accuracy.
Results
From 500 measurements, the results were pretty consistent. (I have run it multiple times with 100 iterations, with pretty much the same results.)
Cells Cells Range Range
(variable) (single) (variable) (single)
avg 124,3 126,4 372,0 329,8
median 125 125 374 328
mode 125 125 374 328
stdev 4,1 4,7 5,7 5,4
min 109 124 358 327
max 156 141 390 344
Interpretation
The Cells method is 2.6 times faster than an equivalent Range method. If concatenation is being used, this adds another 10% execution time, which makes the difference almost 3x. This is a huge difference.
On the other hand though, we are talking about an average of 0.001 ms VS 0.004 ms per cell operation. Unless we are running a script on more than 2-3 hundred thousand cells, this is not going to make a noticeable speed difference.
Conclusion
Yep, there is a huge speed difference.
Nope, I'm not going to bother telling people to use the Cells method unless they process huge amounts of cells.
Test set-up
Win7 64 bit
8 GB RAM
Intel Core i7-3770 # 3.40 GHz
Excel 2013 32 bit
Did I miss anything? Did I cock something up? Please don't hesitate to point it out! Cheers! :)
Code
Public Declare Function GetTickCount Lib "kernel32.dll" () As Long
Sub testCells(j As Long)
Dim i As Long
Dim t1 As Long
Dim t2 As Long
t1 = GetTickCount
For i = 1 To 100000
With Cells(i, 1)
End With
Next i
t2 = GetTickCount
Sheet4.Cells(j, 1) = t2 - t1
End Sub
Sub testRange(j As Long)
Dim i As Long
Dim t1 As Long
Dim t2 As Long
t1 = GetTickCount
For i = 1 To 100000
With Range("A" & i)
End With
Next i
t2 = GetTickCount
Sheet4.Cells(j, 2) = t2 - t1
End Sub
Sub testRangeSimple(j As Long)
Dim i As Long
Dim t1 As Long
Dim t2 As Long
t1 = GetTickCount
For i = 1 To 100000
With Range("A1")
End With
Next i
t2 = GetTickCount
Sheet4.Cells(j, 3) = t2 - t1
End Sub
Sub testCellsSimple(j As Long)
Dim i As Long
Dim t1 As Long
Dim t2 As Long
t1 = GetTickCount
For i = 1 To 100000
With Cells(1, 1)
End With
Next i
t2 = GetTickCount
Sheet4.Cells(j, 4) = t2 - t1
End Sub
Sub runtests()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim j As Long
DoEvents
For j = 1 To 500
testCells j
Next j
DoEvents
For j = 1 To 500
testRange j
Next j
DoEvents
For j = 1 To 500
testRangeSimple j
Next j
DoEvents
For j = 1 To 500
testCellsSimple j
Next j
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
For j = 1 To 5
Beep
DoEvents
Next j
End Sub
I expanded upon the testing after seeing an example of .Cells(1, "A") notation which I thought might be a good balance between the readability of .Range("A1") with the speed of .Cells(1, 1)
I tested reads and writes and found for reads, .Cells(1, "A") executed in about 69% of the time .Range("A1") and .Cells(1, 1) executed in half the time of .Range("A1"). For writes there was a smaller difference (~88% and 82% respectively).
Code:
Option Explicit
Sub test()
Dim i, x, y, a, t1, t2, t3, t4
x=1000000
y=x/100
Debug.Print "---Read---" 'Cell A1 contains the number 55
t1=Timer*1000
For i = 1 to x
a = Sheet1.Range("A1")
Next
t2=Timer*1000
Debug.Print t2 - t1 & "ms"
For i = 1 to x
a = Sheet1.Cells(1, "A")
Next
t3=Timer*1000
Debug.Print t3 - t2 & "ms (" & Round(100*(t3-t2)/(t2-t1),1)&"%)"
For i = 1 to x
a = Sheet1.Cells(1, "A")
Next
t4=Timer*1000
Debug.Print t4 - t3 & "ms (" & Round(100*(t4-t3)/(t2-t1),1)&"%)"
Debug.Print "---Write---"
a=55
t1=Timer*1000
For i = 1 to y
Sheet1.Range("A1") = a
Next
t2=Timer*1000
Debug.Print t2 - t1 & "ms"
For i = 1 to y
Sheet1.Cells(1, "A") = a
Next
t3=Timer*1000
Debug.Print t3 - t2 & "ms (" & Round(100*(t3-t2)/(t2-t1),1)&"%)"
For i = 1 to y
Sheet1.Cells(1, "A") = a
Next
t4=Timer*1000
Debug.Print t4 - t3 & "ms (" & Round(100*(t4-t3)/(t2-t1),1)&"%)"
Debug.Print "----"
End Sub
^transcribed by hand, may contain typos...
Platform:
Excel 2013 32 bit
Windows 7 64 bit
16GB Ram
Xeon E5-1650 v2 #3.5GHz
(edit: changed "x" to "y" in write section of code-see disclaimer on hand-typed code!)
It's worth linking this stack overflow question which further explains how to increase performance:
Slow VBA macro writing in cells
Related
Any idea on how to improve the performance of the code below?
I'm your average engineer (i.e., not a savvy programmer) and was fiddling with a VBA project to get it to run faster. It was taking days, now I got it to run in a couple of hours, but I know that it can be even faster, and the most time consuming part is this one.
I feed the code below with thousands of vectors with Acoustic/Vibration spectra information. For each spectra the code takes about 30 secs to run.
Sub time_test()
'################################################################################################
'This is just to simulate the vector of input data which in reality would be an acoustic spectrum
Dim yval(8000000, 1) As Double
Dim val(8000000, 1) As Double
For i = 0 To 8000000
yval(i, 0) = 100 * Rnd
Next i
Length = 8000001
'################################################################################################
'################################################################################################
'From here on is where I must improve the performance of the code
Timing = Timer
For Index = 1 To Length
val(Index - 1, 1) = 20 * Log10(yval(Index - 1, 0), "Pre")
Next Index
Debug.Print Round(Timer - Timing, 2)
'################################################################################################
End Sub
Public Function Log10(Valeur As Double, sType As String) As Double
Select Case sType
Case "Vib"
If Valeur <> 0 Then
Log10 = Log(Valeur) / Log(10#)
End If
Case "Pre"
If Valeur <> 0 Then
Log10 = Log(Valeur / (2 * (10 ^ -5))) / Log(10#)
End If
End Select
End Function
I have a performance problem in my VBA-Excel code.
I have 42 rows and 55 columns (it can be increased).
My purpose is to merge the cells (in each 2 rows) that have same value using some steps (I want to make a gantt chart).
Before merge
After merge
The first step is merged on column based (for each 2 rows):
compare cell (row, col) and (row+1, col)
If it has same value, compare cell (row, col) and (row, col+1)
if it has same value, compare cell (row, col+1) and (row+1, col+1), check the next column, and go to step 1
if step 2 or 3 is false, then merge the cells from the first cell (row, col) until the last cell that have same value (cell(row + 1, col + n - 1)
if step 1 is false, then go to the next column
after that, I have to merge on row based (still for each 2 rows).
if the cell(row, col) and cell (row, col + 1) are not merged, if cell (row, col) and cell (row, col + 1) have the same value, go to next column.
if step 1 is false, then merge the cells from cell(row, col) until cell(row, col + n - 1)
I have created the code below, but I am facing a performance issue.
The time to finish this code is at least 4 minutes.
I tried to remove the merge line for checking, and the time is only 1 second.
I concluded that there is something not correct on the merge process, but I couldn't figure it out.
If you have any suggestion regarding my code, please share it.
Thank you very much...
Sub MergeCell()
Dim StartTime As Double, RunTime As Double
StartTime = Timer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Dim i As Long, j As Long, jmax1 As Long, maxRows As Long, maxCols As Long
Dim merge As Long, iMerge As Long, jMerge As Long, Jump As Long
Dim chckst As String
maxRows = 42
maxCols = 55
Dim Rng As Range, Rng3 As Range
Set Rng = Sheets("Sheet1").Range("E5").Resize(maxRows, maxCols)
Dim chk As Long
i = 1
Do While i < maxRows
j = 1
Do While j < maxCols
iMerge = 0
jMerge = 0
merge = 0
Jump = 0
If Rng.Cells(i, j).Value2 = Rng.Cells(i + 1, j).Value2 Then
jmax1 = j
iMerge = i + 1
jMerge = jmax1
merge = 1
For chk = jmax1 + 1 To maxCols - 1
If Rng.Cells(i, j).Value2 = Rng.Cells(i, chk).Value2 Then
If Rng.Cells(i, chk).Value2 = Rng.Cells(i + 1, chk).Value2 Then
jmax1 = jmax1 + 1
Else
Jump = 1
Exit For
End If
Else
Exit For
End If
Next
Else
j = j + 1
End If
If merge > 0 Then
'when I removed this merge line, the speed is good, like I said before
Range(Rng.Cells(i, j), Rng.Cells(iMerge, jmax1)).merge
j = jmax1 + 1
If Jump = 1 Then
j = j + 1
End If
End If
Loop
i = i + 2
Loop
RunTime = Round(Timer - StartTime, 2)
MsgBox "Run Time = " & RunTime & " seconds", vbInformation
Dim colId1 As Long, colId2 As Long
Dim colct As Long
i = 1
Do While i <= maxRows
j = 1
Do While j < maxCols
merge = 0
jmax1 = j
If Rng.Cells(i, jmax1).MergeCells = True Then
colct = Rng.Cells(i, jmax1).MergeArea.Columns.Count - 1
jmax1 = jmax1 + colct
j = jmax1 + 1
Else
For chk = jmax1 + 1 To maxCols
If Rng.Cells(i, j) = Rng.Cells(i, chk) And Rng.Cells(i, chk).MergeCells = False Then
merge = 1
colId1 = j
colId2 = jmax1 + 1
If chk <> maxCols Then
jmax1 = jmax1 + 1
Else
j = jmax1 + 1
Exit For
End If
Else
j = jmax1 + 1
Exit For
End If
Next
End If
If merge > 0 Then
'when I removed this merge line, the speed is good, like I said before
Range(Rng.Cells(i, colId1), Rng.Cells(i, colId2)).merge
End If
Loop
i = i + 1
Loop
Rng.HorizontalAlignment = xlCenter
Rng.VerticalAlignment = xlCenter
On Error GoTo HERE
HERE:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
RunTime = Round(Timer - StartTime, 2)
MsgBox "Done!" & vbNewLine & "Run Time = " & RunTime & " seconds", vbInformation
End Sub
The problem is in the conditional formatting.
I only need to remove the conditional formatting before merge, merge it, then put the conditional formatting again.
With this code, everything is fine and fast now. It's only need 2 seconds.
thank you for everyone who contributes to help..
regards,
Suggestion 1
declare variables like this:
Dim i as long, j as long, jmax1 as long, maxRows as long, maxCols as long etc. If you do not specify the type, they get declared as variant. In your line only the last one - Jump is declared as long.
If you redeclare them, it may run faster.
Suggestion 2
Do not use integers in VBA. stackoverflow.com/questions/26409117/
Suggestion 3
Do not use GoTo https://en.wikipedia.org/wiki/Spaghetti_code
Suggestion 4
In general merge is slow in VBA/Excel. But still, to see what you are doing, write this before the merge:
debug.Print Range(Rng.Cells(i, j), Rng.Cells(iMerge, jmax1)).Address
It can be that you are merging more than expected or something else.
I am looking for a simple algorithm which works on the following table:
In the first column you see the constraints. The second column should be used by the algorithm to output the iterations, which should be done like this:
0 0 0
0 0 1
........
0 0 29
0 1 0
........
0 1 29
0 2 0
0 2 1
........
........
27 9 29
28 0 0
........
........
28 9 29
Currently I have the following code:
Dim wksSourceSheet As Worksheet
Set wksSourceSheet = Worksheets("Solver")
Dim lngLastRow As Long
Dim lngLastColumn As Long
With wksSourceSheet
lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
.Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
lngLastColumn = IIf(IsEmpty(.Cells(1, .Columns.Count)), _
.Cells(1, .Columns.Count).End(xlToLeft).Column, .Columns.Count)
Dim intRowOuter As Integer
Dim intRowInner As Integer
For intRowOuter = 2 To lngLastRow
.Cells(intRowOuter, lngLastColumn).Value = 0
Next intRowOuter
For intRowOuter = lngLastRow To 2 Step -1
For intRowInner = lngLastRow To intRowOuter Step -1
Dim constraint As Integer
Dim intConstraintCounter As Integer
intConstraint = .Cells(intRowInner, 1)
For intConstraintCounter = 1 To intConstraint
.Cells(intRowInner, lngLastColumn).Value = intConstraintCounter
Next intStampCounter
Next intRowInner
Next intRowOuter
End With
This might be a right approach but something is incorrect. I'm unfortunately stuck so I would appreciate some help on fixing this.
Solution
I would suggest using one array to store the constraints and one to represent the counter.
Dim MaxNum() As Long
Dim myCounter() As Long
ReDim MaxNum(1 To NumDigits)
ReDim myCounter(1 To NumDigits)
Next you need to initialize MaxNum. This will probably involve looping through the cells containing the constraints. Something like:
Dim constraintRange As Range
Dim i As integer
Set constraintRange = wksSourceSheet.Range("A2:A4")
For i = 1 to numDigits
MaxNum(i) = constraintRange.Cells(i,1).Value
Next i
Now we just need to write an increment counter function! The idea is pretty simple we just go from the least significant digit to the most significant. We increment the LSD and, if there is overflow we set it to 0 and then add 1 to the next digit. It looks like this:
Sub IncrNum(ByRef myNum() As Long, ByRef MaxNum() As Long)
Dim i As Integer
For i = LBound(myNum) To UBound(myNum)
myNum(i) = myNum(i) + 1
If myNum(i) > MaxNum(i) Then 'Overflow!
myNum(i) = 0 'Reset digit to 0 and continue
Else
Exit For 'No overflow so we can just exit
End If
Next i
End Sub
Which is just one for-loop! I think this will be the cleanest solution :)
NOTE: To use this function you would simply do IncrNum(myCounter, MaxNum). Which would change the value of myCounter to the next in the sequence. From here you can paste to a range by doing dstRange = myCounter.
Testing
In my own tests I used a while loop to print out all of the values. It looked something like this:
Do While Not areEqual(MaxNum, myCounter)
Call IncrNum(myCounter,MaxNum)
outRange = myCounter
Set outRange = outRange.Offset(1, 0)
Loop
areEqual is just a function which returns true if the parameters contain the same values. If you like I can provide my code otherwise I will leave it out to keep my answer as on track as it can be.
Maybe something like this can be modified to fit your needs. It simulates addition with carry:
Sub Clicker(MaxNums As Variant)
Dim A As Variant
Dim i As Long, j As Long, m As Long, n As Long
Dim sum As Long, carry As Long
Dim product As Long
m = LBound(MaxNums)
n = UBound(MaxNums)
product = 1
For i = m To n
product = product * (1 + MaxNums(i))
Next i
ReDim A(1 To product, m To n)
For j = m To n
A(1, j) = 0
Next j
For i = 2 To product
carry = 1
For j = n To m Step -1
sum = A(i - 1, j) + carry
If sum > MaxNums(j) Then
A(i, j) = 0
carry = 1
Else
A(i, j) = sum
carry = 0
End If
Next j
Next i
Range(Cells(1, 1), Cells(product, n - m + 1)).Value = A
End Sub
Used like:
Sub test()
Clicker Array(3, 2, 2)
End Sub
Which produces:
x%10 or x Mod 10 give the remainder when x is divided by 10 so you will get the last digit of x.
Since your problem is specifically asking for each digit not to exceed 463857. You can have a counter incrementing from 000000 to 463857 and only output/use the numbers the fullfill the following condition:
IF(x%10 <= 7 AND x%100 <=57 AND x%1000 <= 857 AND x%10000 <=3857 AND x%100000 <= 63857 AND x <= 463857)
THEN //perform task.
I have this code which runs two loops after each other. It works fine for a few thousand rows. But as the number of rows increases, the code runs significantly longer. It should loop over 100.000 rows but this will take hours and hours.
Please let me know if you see a reason why this code is taking so long
Sub BSIS()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim lngRow As Long
Dim counter As Long
'Merge rows with duplicate Cells
With ActiveSheet
.Cells(1).CurrentRegion.Sort key1:=.Cells(1), Header:=xlYes 'change this to xlYes if your table has header cells
For lngRow = ActiveSheet.UsedRange.Rows.Count To 2 Step -1
If ActiveSheet.Cells(lngRow - 1, 1) = ActiveSheet.Cells(lngRow, 1) Then
.Cells(lngRow - 1, 4) = .Cells(lngRow - 1, 4) + .Cells(lngRow, 4)
.Rows(lngRow).Delete
End If
Next lngRow
End With
'Delete rows with negative cells
With ActiveSheet
For counter = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
If ActiveSheet.Cells(counter, 4) <= 0 Then
.Rows(counter).Delete
End If
Next counter
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
one option would be copying the range of data you want to examine into an array. Do what ever data processing you want with that array, then copy the results back into the excel sheet. Here is an example:
Dim i As Integer
Dim j As Integer
Dim flagMatch As Boolean
Dim arrData2Search As Variant
Set arrData2Search = Range(Cells(1, 1), Cells(1000, 2000)).value
flagMatch = False
For j = 1 To 1000
For i = 1 To 2000
If arrData2Search (i, j)= "Target" Then
flagMatch = True
End If
Next i
Next j
The reason for slow run is that you are deleting rows one by one.
It always better to do it in single shot using UNION function
Try the below code it should work,(Tested)
Dim uni As Range
With ActiveSheet
.Cells(1).CurrentRegion.Sort key1:=.Cells(1), Header:=xlYes
For lngRow = ActiveSheet.UsedRange.Rows.Count To 2 Step -1
If ActiveSheet.Cells(lngRow - 1, 1) = ActiveSheet.Cells(lngRow, 1) Then
.Cells(lngRow - 1, 4) = .Cells(lngRow - 1, 4) + .Cells(lngRow, 4)
If Not uni Is Nothing Then
Set uni = Application.Union(uni, Range(.Rows(lngRow).Address))
Else
Set uni = Range(.Rows(lngRow).Address)
End If
End If
Next lngRow
uni.Delete
End With
There are a number of ways to optimize performance of one's VBA code, and a good number of articles and forums have covered the topic. For a great resource, see this.
One of the main things to remember is that every time your code interacts with the UI of Excel, it uses much more overhead than if the interaction had not occurred. That's why (to VBA Programmer's point) it's much faster to load the data to an array, perform your calculations, and then write the array back to a sheet. And that's why (to Sathish's point) it's much faster to delete all the rows at once (one interaction) compared to each one individually (multiple interactions). For more information about deleting rows, see this.
With regards to your code, is there any particular reason you need two loops?
Untested
Sub BSIS()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim lngRow As Long
Dim r As Range
With ActiveSheet
.Cells(1).CurrentRegion.Sort key1:=.Cells(1), HEADER:=xlYes 'change this to xlYes if your table has header cells
'One loop:
For lngRow = .UsedRange.Rows.Count To 2 Step -1
'Merge rows with duplicate Cells
If .Cells(lngRow - 1, 1) = .Cells(lngRow, 1) Then
.Cells(lngRow - 1, 4) = .Cells(lngRow - 1, 4) + .Cells(lngRow, 4)
If r Is Nothing Then
Set r = .Cells(lgnrow, 1)
Else: Set r = Union(r, .Cells(lgnrow, 1))
End If
'Delete rows with negative cells
If .Cells(lngRow, 4) <= 0 Then
If r Is Nothing Then
Set r = .Cells(lngRow, 1)
Else: Set r = Union(r, .Cells(lgnrow, 1))
End If
Next lngRow
End With
'Delete rows
r.EntireRow.Delete
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Suppose I want to build the bit mask with the Nth bit set. I have N as an integer.
Which is better? 1 << N or a lookup table (pointer arithmetic addition)?
My guess is that a single bit shift operation is faster than a memory lookup, and only once cache-hot does LUT have a fighting chance. However if this is the case then why are LUT's so often the fastest solution in bit-twiddling problems? Is it simply because of the huge caches we have in our CPU's these days?
Let me qualify the question with the fact that I care the most about this operation at this moment on x86-64.
A bit shift will always be far faster than either a look-up table or a calc.
Are you sure? I ran this VB program and the results were a bit variable, but lookup was usually quicker than bit shifting, and not much higher than the null time. This is probably because of caching, so it's hard to generalise from this.
I got a similar result from a random shift value, but of course the random number generation was taking longer than anything else.
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
Dim SW As New Stopwatch()
Dim TimeShift As Long
Dim TimeLookUp As Long
Dim Timenull As Long
Dim i As Integer
Dim j As Integer
Dim Bit As UInteger
Dim R As New Random()
Dim total As UInteger
Dim S = New System.Text.StringBuilder()
total = 0
SW.Start()
j = 0
For i = 1 To RepCount
Bit = CUInt(1) << (j And 31)
j += 1
'Bit = 1 << (R.Next(31))
total = total Or Bit
Next
SW.Stop()
TimeShift = SW.ElapsedMilliseconds
SW.Reset()
SW.Start()
For i = 1 To RepCount
Bit = Bits(j And 31)
j += 1
'Bit = Bits(R.Next(31))
total = total Or Bit
Next
SW.Stop()
TimeLookUp = SW.ElapsedMilliseconds
SW.Reset()
SW.Start()
For i = 1 To RepCount
total = total Or (j And 31)
j += 1
Next
SW.Stop()
Timenull = SW.ElapsedMilliseconds
If Stopwatch.IsHighResolution Then
S.Append("High")
Else
S.Append("Low")
End If
S.Append(" frequency clock")
S.AppendLine()
S.Append("Shift time= " & TimeShift & " ms")
S.AppendLine()
S.Append("Lookup time= " & TimeLookUp & " ms")
S.AppendLine()
S.Append("Null time=" & Timenull & " ms")
S.AppendLine()
S.Append("Total= " & total.ToString)
MsgBox(S.ToString)
End Sub
End Class