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
Related
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
I am trying to round up numbers in a legacy application which I had coded in VB6 to obtain the following outcomes:
2.53 should be 2.60
2.55 should be 2.60
2.56 should be 2.60
2.50 should remain 2.50
2.501 should be 2.50
2.505 should be 2.60
I have tried to use the suggested User-Defined Rounding functions by Microsoft
http://support.microsoft.com/kb/196652/en-gb
The closest I arrived to is the Asymup function
Function AsymUp(ByVal X As Double, _
Optional ByVal Factor As Double = 1) As Double
Dim Temp As Double
Temp = Int(X * Factor)
AsymUp = (Temp + IIf(X = Temp, 0, 1)) / Factor
End Function
I am testing this procedure by calling the function as follows:
Text1.Text = AsymUp(Val(Text1.Text), 10)
But this is not producing the desired results because 2.60 for example becomes 2.7 when I want it to remain 2.6. Strangely enough 2.0 also becomes 2.1, implying that the function is not working well.
How can I correct this to acheive the desired results
Private Function AsymUp(ByVal D As Double, Optional Precision As Double = 1) As Double
Precision = CDbl("1" & String$(Precision, 48))
D = D * Precision
If Int(D) <> D Then
AsymUp = (Int(D) + 1) / Precision
Else
AsymUp = D / Precision
End If
End Function
Visual Basic will always automatically truncate trailing zeros from Double and Single data types. Therefore, unless a function is designed to pass the number back as a string, along with the extra zero(s) appended, it will be impossible to retain trailing zeros of a particular precision.
Bonus tip: The IIf function should not be used where performance is of concern, as both the falsepart and truthpart parameters are always evaluated, regardless of the arguments passed to them.
String manipulation method (retains zeros):
Private Function AsymUp(ByVal D As Double, Optional Precision As Double = 1) As String
Dim P As Double, Z As Long
P = CDbl("1" & String$(Precision, 48))
D = D * P
If Int(D) <> D Then
D = (Int(D) + 1) / P
Else
D = D / P
End If
AsymUp = CStr(D)
Z = Precision - (Len(AsymUp) - InStr(AsymUp, "."))
If Z > 0 Then AsymUp = AsymUp & String$(Z, 48)
End Function
This will obviously not be as efficient to run as my other answer, but it's the only way to keep any trailing zeros intact.
Please note that the function will always return the number as a string. You may need to convert the string back to a decimal number to continue using the number with additional mathematics in your program.
I've resolved the issue using the following code:
Private Sub Command1_Click()
roundnumber = Val(Text1.Text)
Text1.Text = Round(roundnumber, 2)
Text1.Text = AsymUp(Val(Text1.Text), 10)
End Sub
Function AsymUp(ByVal X As Double, _
Optional ByVal Factor As Double = 1) As Double
Dim Temp As Double
Temp = Int(X * Factor)
AsymUp = (Temp + IIf((X * Factor) = Temp, 0, 1)) / Factor
End Function
This is what I was after not precision to 10dp as suggested in this post.
Basically I am trying to solve a 2nd order differential equation with the forward euler method. I have some for loops inside my code, which take considerable time to solve and I would like to speed things up a bit. Does anyone have any suggestions how could I do this?
And also when looking at the time it takes, I notice that my end at line 14 takes 45 % of my total time. What is end actually doing and why is it taking so much time?
Here is my simplified code:
t = 0:0.01:100;
dt = t(2)-t(1);
B = 3.5 * t;
F0 = 2 * t;
BB=zeros(1,length(t)); % Preallocation
x = 2; % Initial value
u = 0; % Initial value
for ii = 1:length(t)
for kk = 1:ii
BB(ii) = BB(ii) + B(kk) * u(ii-kk+1)*dt; % This line takes the most time
end % This end takes 45% of the other time
x(ii+1) = x(ii) + dt*u(ii);
u(ii+1) = u(ii) + dt * (F0(ii) - BB(ii));
end
Running the code it takes me 8.552 sec.
You can remove the inner loop, I think:
for ii = 1:length(t)
for kk = 1:ii
BB(ii) = BB(ii) + B(kk) * u(ii-kk+1)*dt; % This line takes the most time
end % This end takes 45% of the other time
x(ii+1) = x(ii) + dt*u(ii);
u(ii+1) = u(ii) + dt * (F0(ii) - BB(ii));
end
So BB(ii) = BB(ii) (zero at initalisation) + sum for 1 to ii of BB(kk)* u(ii-kk+1).dt
but kk = 1:ii, so for a given ii, ii-kk+1 →　ii-(1:ii) + 1 → ii:-1:1
So I think this is equivalent to:
for ii = 1:length(t)
BB(ii) = sum(B(1:ii).*u(ii:-1:1)*dt);
x(ii+1) = x(ii) + dt*u(ii);
u(ii+1) = u(ii) + dt * (F0(ii) - BB(ii));
end
It doesn't take as long as 8 seconds for me using either method, but the version with only one loop is about 2x as fast (the output of BB appears to be the same).
Is the sum loop of B(kk) * u(ii-kk+1) just conv(B(1:ii),u(1:ii),'same')
The best way to speed up loops in matlab is to try to avoid them. Try if you are able to perform a matrix operation instead of the inner loop. For example try to break the calculation you do there in small parts, then decide, if there are parts you can perform in advance without knowing the results of the next iteration of the loop.
to your secound part of the question, my guess:: The end contains the check if the loop runs for another round and this check by it self is not that long but called 50.015.001 times!
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
What's the best way to test two Singles for equality in VB6?
I want to test two Single values for equality to 7 significant figures.
This MSDN article recommends using something like
If Abs(a - b) <= Abs(a / 10 ^ 7) Then
valuesEqual = True
End If
However, that can fail for certain values, e.g.
Public Sub Main()
Dim a As Single
Dim b As Single
a = 0.50000005
b = 0.50000014
Debug.Print "a = " & a
Debug.Print "b = " & b
Debug.Print "a = b: " & (a = b)
Debug.Print "SinglesAreEqual(a, b): " & SinglesAreEqual(a, b)
// Output:
// a = 0.5000001
// b = 0.5000001
// b = b: False
// SinglesAreEqual(a, b): False
End Sub
Private Function SinglesAreEqual(a As Single, b As Single) As Boolean
If Abs(a - b) <= Abs(a / 10 ^ 7) Then
SinglesAreEqual = True
Else
SinglesAreEqual = False
End If
End Function
The simplest way I've found of getting the result I need is to convert the values to strings, but seems horribly ugly:
Private Function SinglesAreEqual(a As Single, b As Single) As Boolean
SinglesAreEqual = (Str$(a) = Str$(b))
End Function
Are there any better ways?
I maintain a CAD/CAM application and I have to deal with floating point numbers all the time. I have a function that I call fComp that I pass a floating point value when I need to test for equality. fComp call a rounding function set to a certain level of precision. For our system I round to 6 decimal places. Yours may need higher or get away with lower it depends on the application.
The fComp Function exists so I have one spot to change the rounding factor used in these calculations. This proved handy a couple of years back when we started manufacturing higher precision machines.
Public Function pRound(ByVal Value As Double, ByVal Power As Double) As Double
Dim TempValue As Double
Dim tSign As Double
TempValue = Value
tSign = TempValue
TempValue = Abs(TempValue)
TempValue = TempValue * 10 ^ (Power * -1)
TempValue = Fix(TempValue + 0.5)
TempValue = TempValue / 10 ^ (Power * -1)
pRound = TempValue * Sign(tSign)
End Function
To round to the 6th decimal place you go
RoundedNumber = pRound(MyValue, -6)
Negative is to the right of the decimal place positive to the left.
Instead if rounding and testing for equality, you can take the difference of two numbers and compare that with a factor
If Abs(a - b) < 0.000001 Then
You can adjust the 0.000001 to whatever resolution you need
I don't believe you can use the single data type to that many significant figures. You would need to use double instead:
Dim a As Single
Dim s As String
s = "0.50000005"
a = 0.50000005
Debug.Print s & " " & a
The above outputs:
0.50000005
0.5000001