I have already resolved several others using Application.Index with Application.WorksheetFunction.Match and reduced time to perform from about 7-8 seconds to milliseconds. But I feel there is still room for improvement.
Should I use an array with Index and Match?
I was also told to use Scripting.Dictionary, but I am looking for someone who can demonstrate how to do it the right way in this scenario. Because in my head I have to populate the dictionary with a loop before I can even use that, so wont it be similar in terms of speed?
'Production Quantity for Dashboard
For i = 2 To Total_rows_Prod
For j = 2 To Total_rows_Dash
If ThisWorkbook.Worksheets("Prod. Qty.").Cells(i, 5) = ThisWorkbook.Worksheets("Dashboard").Cells(j, 1) Then
ThisWorkbook.Worksheets("Dashboard").Cells(j, 4) = ThisWorkbook.Worksheets("Dashboard").Cells(j, 4) + ThisWorkbook.Worksheets("Prod. Qty.").Cells(i, 31) / ThisWorkbook.Worksheets("Prod. Qty.").Cells(i, 4)
End If
Next j
Next i
After doing some bottleneck testing, using a nested for-next loop is known to be extremely slow and bad practice as shown below (run time of code is shown at row 10):
However, when using Index and Match while only using 1 for-next loop as shown in the code below:
'Production Quantity for Dashboard
For i = 2 To Total_rows_Prod
m = Application.Match(ThisWorkbook.Worksheets("Prod. Qty.").Cells(i, 5), ThisWorkbook.Worksheets("Dashboard").Range("A:A"), 0)
If Not IsError(m) Then
ThisWorkbook.Worksheets("Dashboard").Cells(Application.WorksheetFunction.Match(ThisWorkbook.Worksheets("Prod. Qty.").Cells(i, 5), ThisWorkbook.Worksheets("Dashboard").Range("A:A"), 0), 4) = ThisWorkbook.Worksheets("Dashboard").Cells(Application.WorksheetFunction.Match(ThisWorkbook.Worksheets("Prod. Qty.").Cells(i, 5), ThisWorkbook.Worksheets("Dashboard").Range("A:A"), 0), 4) + ThisWorkbook.Worksheets("Prod. Qty.").Cells(i, 31) / ThisWorkbook.Worksheets("Prod. Qty.").Cells(i, 4)
End If
Next i
The run time would be negligible as shown below (still at row 10):
The final time (as of 1/21/19) I was able to make everything run with Index and Match replacements was 2 seconds:
On a slower netbook running a Pentium Atom processor, it takes 26 seconds to perform the same code (13 times longer). So I am wondering if there is way to bring down that 26 seconds.
Any improvements that would make the time to perform optimally minimized would be great. Hopefully making it the fastest possible.
Update as of 2/23/19 (Code Revision):
Dim rangeProdQtySum As Range, rangeProdQtyPass As Range
Set rangeProdQtySum = ThisWorkbook.Worksheets("Prod. Qty.").Range("AE1:AE" & Total_rows_Prod)
Set rangeProdQtyPass = ThisWorkbook.Worksheets("Prod. Qty.").Range("D1:D" & Total_rows_Prod)
ReDim arrProdQtySum(1 To Total_rows_Prod) As Variant
ReDim arrProdQtyPass(1 To Total_rows_Prod) As Variant
arrProdQtySum = rangeProdQtySum
arrProdQtyPass = rangeProdQtyPass
ReDim arrProdQtyDash(1 To Total_rows_Dash) As Variant
'Production Quantity for Dashboard
For i = 2 To Total_rows_Prod
m = Application.Match(arrProdQtyJTJN(i, 1), Application.Index(Application.WorksheetFunction.Transpose(arrDashInfo), 0, 1), 0)
If Not IsError(m) Then
arrProdQtyDash(Application.Match(arrProdQtyJTJN(i, 1), Application.Index(Application.WorksheetFunction.Transpose(arrDashInfo), 0, 1), 0)) = arrProdQtyDash(Application.Match(arrProdQtyJTJN(i, 1), Application.Index(Application.WorksheetFunction.Transpose(arrDashInfo), 0, 1), 0)) + arrProdQtySum(i, 1) / arrProdQtyPass(i, 1)
End If
Next i
arrProdQtyDash(1) = "Production Quantity"
ThisWorkbook.Worksheets("Dashboard").Range("D1:D" & Total_rows_Dash) = Application.WorksheetFunction.Transpose(arrProdQtyDash)
With arrays, minimizing usage of for-next loops, use index and match with combinations to arrays, and memorization of variables (assigning references to a variable), the timer are as follows:
The same set of codes that I tried on the slower pentium atom computer takes 10 seconds to perform the same code as shown below:
This is about 2.6x faster than simply using the index and match codes. I am wondering if there are any more improvements to be suggested for the code snippet displayed here because it is the bottleneck (takes 5 seconds to perform on the pentium atom or about 50% of the processing time).
Related
I am having trouble with some loops in some code that I have inherited but that I can't get to run. I have passed what I assume are the correct values into the function (see my previous question), but now I am struggling to have the initial loops work.
The function works fine when called in a cell. However, when it runs in this macro, it is giving me a few errors, which I have chased back to the ReDim of the Lambda and v variables.
When I check it in the debugger, Lambda has the value of 0.33, but the value of the variable Splines is 1, and there is no variable with the value 0.33 that it could be picking up nearby.
Meanwhile I would expect V to pick up the value of 2, i.e. 1+1, but instead it has the value of 0.
I cannot work out why this is happening. Here is the code.
Function Spline(form As String, Splines As Integer, params As Variant, knots As Variant, coef As Variant, tstar As Range) 'form is type of spline, splines is number of knots, params is gammas, knots as knot posititions, coef as 0, tstar as cycle length in days
Dim Lambda As Variant
Dim v As Variant
Dim kmin, kmax As Double
Dim vtstar As Variant
Dim vspline As Variant
Dim a As Long
vtstar = tstar.Value2 'set vtstar as second value of the array of the cycle length
ReDim vspline(1 To UBound(vtstar), 1 To 1) 'set vspline to be cycle lengths without the 0
For a = 1 To UBound(vtstar) 'for each cycle to the max cycle
If vtstar(a, 1) = 0 Then 'for each cycle
vspline(a, 1) = 1 'recoding the days cycles into cycle number
'Exit Function
GoTo Avert 'unsure of this functionality, i think its just part of the loop syntax, by the 'exit function notation
End If
timeS = Log(vtstar(a, 1)) 'set timeS as the log of the cycle length
ReDim Lambda(Splines, 0) 'set lambda to number of knots
ReDim v(Splines + 1, 0) 'recode v to number of knots plus 1
v(0, 0) = 1
v(1, 0) = timeS 'unsure about this part
This is causing errors when the lambda and v variables are used in calculations further down in the function, first causing the lambda calculations to give "subscript out of range" error when called in this loop, I assume because 0.33 isn't a cycle number:
For i = 1 To Splines 'loop for each variable in splines (number of knots)
Lambda(i, 0) = (kmax - knots(i + 1)) / ulamb 'calculate lambda as kmax - knots+1 divided by difference between max and min knot values
Next i
(kmax, knots and ulamb appear to be calculating correctly)
And then I am getting a Error2015 error on the following loop which uses v
s = Application.SumProduct(params, v) 'set s as multiply gammas by v
Thanks in advance
Unclear what your previous question was.
Struggle a bit with your description.
the value of the variable Splines is 1
Is Splines a constant = 1? You do not show how Splines is a variable but you state it is equal to the number of knots...
ReDim Lambda(Splines, 0) 'set lambda to number of knots
If Splines = 1, you are re-dimensioning Lambda to an array of size 2x1. So your array will hold two values.
For i = 1 To Splines 'loop for each variable in splines (number of knots)
Lambda(i, 0) = (kmax - knots(i + 1)) / ulamb 'calculate lambda as kmax - knots+1 divided by difference between max and min knot values
Next i
If Splines = 1 you are starting your loop at 1 and ending at 1... So your array Lambda(0, 0) is empty. You will have a value in Lambda(1, 0).
I have a dataframe containing 6.3 million records and 111 columns. For this example I've limited the dataframe to 27 columns (A-Z). On this dataframe I am trying to run an analysis in which I use different combinations of the columns (with pairs of 5 columns per combination) and subset each of those on the dataframe and do a count of the number of occurrences for each combination and finally evaluate if this count extends a certain threshold and then store the combination. The code is already optimized with an efficient way of running the individual subsets, using numba. But still the overal script I have takes quite some time (7-8 hours). This is because if you use for example 90 columns (which is my actual number used) to make combinations of 5, you get 43.949.268 different combinations. In my case I also use a shifted versions of some columns (value of day before). So for this example I've limited it to 20 columns (A-J 2 times, including the shifted versions).
The columns used are stored in a list, which is converted to numbers because it otherwise gets to big using long strings. The names in the list corresponds with a dictionary containing the subset variables.
Here is the full code example:
import pandas as pd
import numpy as np
import numba as nb
import time
from itertools import combinations
# Numba preparation
#nb.njit('int64(bool_[::1],bool_[::1],bool_[::1],bool_[::1],bool_[::1])', parallel=True)
def computeSubsetLength5(cond1, cond2, cond3, cond4, cond5):
n = len(cond1)
assert len(cond2) == n and len(cond3) == n and len(cond4) == n and len(cond5) == n
subsetLength = 0
for i in nb.prange(n):
subsetLength += cond1[i] & cond2[i] & cond3[i] & cond4[i] & cond5[i]
return subsetLength
# Example Dataframe
np.random.seed(101)
bigDF = pd.DataFrame(np.random.randint(0,11,size=(6300000, 26)), columns=list('ABCDEFGHIJKLMNOPQRSTUVWXYZ'))
# Example query list
queryList = ['A_shift0','B_shift0','C_shift0','D_shift0','E_shift0','F_shift0','G_shift0','H_shift0','I_shift0','J_shift0','A_shift1','B_shift1','C_shift1','D_shift1','E_shift1','F_shift1','G_shift1','H_shift1','I_shift1','J_shift1']
# Convert list to numbers for creation combinations
listToNum = list(range(len(queryList)))
# Generate 15504 combinations of the 20 queries without repitition
queryCombinations = combinations(listToNum,5)
# Example query dict
queryDict = {
'query_A_shift0': ((bigDF.A >= 1) & (bigDF.A < 3)),
'query_B_shift0': ((bigDF.B >= 3) & (bigDF.B < 5)),
'query_C_shift0': ((bigDF.C >= 5) & (bigDF.C < 7)),
'query_D_shift0': ((bigDF.D >= 7) & (bigDF.D < 9)),
'query_E_shift0': ((bigDF.E >= 9) & (bigDF.E < 11)),
'query_F_shift0': ((bigDF.F >= 1) & (bigDF.F < 3)),
'query_G_shift0': ((bigDF.G >= 3) & (bigDF.G < 5)),
'query_H_shift0': ((bigDF.H >= 5) & (bigDF.H < 7)),
'query_I_shift0': ((bigDF.I >= 7) & (bigDF.I < 9)),
'query_J_shift0': ((bigDF.J >= 7) & (bigDF.J < 11)),
'query_A_shift1': ((bigDF.A.shift(1) >= 1) & (bigDF.A.shift(1) < 3)),
'query_B_shift1': ((bigDF.B.shift(1) >= 3) & (bigDF.B.shift(1) < 5)),
'query_C_shift1': ((bigDF.C.shift(1) >= 5) & (bigDF.C.shift(1) < 7)),
'query_D_shift1': ((bigDF.D.shift(1) >= 7) & (bigDF.D.shift(1) < 9)),
'query_E_shift1': ((bigDF.E.shift(1) >= 9) & (bigDF.E.shift(1) < 11)),
'query_F_shift1': ((bigDF.F.shift(1) >= 1) & (bigDF.F.shift(1) < 3)),
'query_G_shift1': ((bigDF.G.shift(1) >= 3) & (bigDF.G.shift(1) < 5)),
'query_H_shift1': ((bigDF.H.shift(1) >= 5) & (bigDF.H.shift(1) < 7)),
'query_I_shift1': ((bigDF.I.shift(1) >= 7) & (bigDF.I.shift(1) < 9)),
'query_J_shift1': ((bigDF.J.shift(1) >= 7) & (bigDF.J.shift(1) < 11))
}
totalCountDict = {'queryStrings': [],'totalCounts': []}
# Loop through all query combinations and count subset lengths
start = time.time()
for combi in list(queryCombinations):
tempList = list(combi)
queryOne = str(queryList[tempList[0]])
queryTwo = str(queryList[tempList[1]])
queryThree = str(queryList[tempList[2]])
queryFour = str(queryList[tempList[3]])
queryFive = str(queryList[tempList[4]])
queryString = '-'.join(map(str,tempList))
count = computeSubsetLength5(queryDict["query_" + queryOne].to_numpy(), queryDict["query_" + queryTwo].to_numpy(), queryDict["query_" + queryThree].to_numpy(), queryDict["query_" + queryFour].to_numpy(), queryDict["query_" + queryFive].to_numpy())
if count > 1300:
totalCountDict['queryStrings'].append(queryString)
totalCountDict['totalCounts'].append(count)
print(len(totalCountDict['totalCounts']))
stop = time.time()
print("Loop time:", stop - start)
This currently takes about 20 seconds on my Macbook Pro 2020 Intel version, for the 15504 combinations. Any thoughts on how this could be improved? I have tried using multiprocessing, but since I am using numba already for the individual subsets this did not work well together. Am I using an inefficient way to do multiple subsets using a list, dictionary and for loop to subset all the combinations, or is 7-8 hours realistic for doing 44 million subsets on a dataframe of 6.3 million records?
One solution to speed up by a large factor this code is to pack the bits in the boolean arrays stored in queryDict. Indeed, the code computeSubsetLength5 is likely memory bound (I thought the speed-up provided in my previous answer would be sufficient for the needs).
Here is the function to pack the bits of a boolean array:
#nb.njit('uint64[::1](bool_[::1])')
def toPackedArray(cond):
n = len(cond)
res = np.empty((n+63)//64, dtype=np.uint64)
for i in range(n//64):
tmp = np.uint64(0)
for j in range(64):
tmp |= nb.types.uint64(cond[i*64+j]) << j
res[i] = tmp
# Remainder
if n % 64 > 0:
tmp = 0
for j in range(n - (n % 64), n):
tmp |= cond[j] << j
res[len(res)-1] = tmp
return res
Note that the end of the arrays are padded with 0 which does not affect the specific following computation (it may not be the case if you plan to use the boolean arrays in another context).
This function is called once for each array like this:
'query_A_shift0': toPackedArray((((bigDF.A >= 1) & (bigDF.A < 3))).to_numpy()),
Once packed, the array can be computed much more efficiently by working directly on 64-bits integers (64-bits per integers are computed at once). Here is the resulting code:
# See: https://en.wikipedia.org/wiki/Hamming_weight
#nb.njit('uint64(uint64)', inline='always')
def popcount64c(x):
m1 = 0x5555555555555555
m2 = 0x3333333333333333
m4 = 0x0f0f0f0f0f0f0f0f
h01 = 0x0101010101010101
x -= (x >> 1) & m1
x = (x & m2) + ((x >> 2) & m2)
x = (x + (x >> 4)) & m4
return (x * h01) >> 56
# Numba preparation
#nb.njit('uint64(uint64[::1],uint64[::1],uint64[::1],uint64[::1],uint64[::1])', parallel=True)
def computeSubsetLength5(cond1, cond2, cond3, cond4, cond5):
n = len(cond1)
assert len(cond2) == n and len(cond3) == n and len(cond4) == n and len(cond5) == n
subsetLength = 0
for i in nb.prange(n):
subsetLength += popcount64c(cond1[i] & cond2[i] & cond3[i] & cond4[i] & cond5[i])
return subsetLength
popcount64c counts the number of bits set to 1 in each 64-bits chunks.
Here are results on my 6-core i5-9600KF machine:
Reference implementation: 13.41 s
Proposed implementation: 0.38 s
The proposed implementation is 35 times faster than the (already optimized) Numba implementation. The reason why it is much faster than just 8 times is that data should now fit in the last-level cache of your processor with is often much faster than the RAM (about 5 times on my machine).
If you when to optimize further this code you can work on smaller chunks that fits in the L2 cache and use threads in the combinatoric loop rather than in the still memory bound computeSubsetLength5 function. This should give you a significant speed-up (I expect at least a x2).
The biggest optimisation to apply then probably comes from the overall algorithm. The same logical AND operations are computed several times over and over. Pre-computing most of them on the fly while keeping only the most useful ones should significantly speed the algorithm up (I expect a speed-up of x2).
I am pretty sure there are many other optimisations that can be applied on on the overall algorithm. Performing a brute-force is often sufficient to solve a problem but hardly a requirement.
I am trying to create an automated Goal Seek script for a interlinked cells and workbook. However, perhaps due to the complexity and number of interlinks, somehow under a certain condition the Goal Seek function converges at a very high or low x-value.
Is there a way to improve its accuracy by setting some kind of boundary (a < x < b) similar to that in Solver. The reason I don't want to add solver in VBA is that because some of the other users may not be activating their Solver add-ins.
This is what the Goal Seek value gives me for an initial guess of x =
0.5h = 500
This is what the X-value should be, with a random guess of x = 100
Another alternative that I could think about is to create some sort of manual iteration (e.g. Bisection method) Sub Routine, but again, the equations are pretty complex so this may not be ideal.
What I am doing at the moment is that to preset an initial value for the x if y (another parameter) is negative or positive. I reckon this has eliminated most of the invalid result, but it still gives an error on one or two occasion. Appreciate your input. Thanks.
Sub Guess()
' ------------- For Guessing Initial X-Value -----------
Dim i As Integer, j As Integer
For i = 4 To 11
For j = 18 To 25
If Worksheets("Crack Width").Range("I" & j) < 0 Then
'------------------------Pre-guess X_value to be 0.5X_bal if N<0-------------
Worksheets("Calcs").Range("B" & i) = Worksheets("Calcs").Range("C" & i).Value * 0.5
If Worksheets("Calcs").Range("B" & i) = 0 Then Worksheets("Calcs").Range("B" & i).ClearContent
i = i + 1
ElseIf Worksheets("Crack Width").Range("I" & j) >= 0 Then
'------------------------Pre-guess X_value to be 0.5h if N>0-------------
Worksheets("Calcs").Range("B" & i) = Worksheets("Calcs").Range("E" & i).Value * 0.5
If Worksheets("Calcs").Range("B" & i) = 0 Then Worksheets("Calcs").Range("B" & i).ClearContents
i = i + 1
End If
Next j
Next i
End Sub
I am trying to generate random colors (2,6) using the following code below; however, my end goal is to generate white color (2) more than the rest of the colors. Would appreciate if someone could help. Thank you.
GenerateColor = Int(Rnd() * 5) + 2
It is a probably a good idea to separate the randomization logic and the logic, which forces a given color to be created more often. E.g., this one works quite ok, giving equal chances to each number:
randomColor = CLng(rnd() * 5) + 2
However, once you obtain the randomColor, it could be changed based on some percentage, named priorityPercentage in the function:
Public Sub TestMe()
Dim counter As Long
Dim randomColor As Long
With Worksheets(1)
.Cells.Clear
For counter = 1 To 1000000
randomColor = CLng(rnd() * 5) + 2
.Cells(counter, 1) = GenerateColor(randomColor, 2, (0.4 - 0.4 * 1 / 6))
Next
.Cells(1, 2).Formula = "=COUNTIF(A:A,2)"
End With
End Sub
Public Function GenerateColor(randomColor As Long, _
priorityColor As Long, _
priorityPercentage As Double) As Long
If rnd() <= priorityPercentage Then
GenerateColor = priorityColor
Exit Function
End If
GenerateColor = CLng(rnd() * 5) + 2
End Function
This example runs 1 million times and it writes in B2 the count of the 2. The reason to pass 0.4 - 0.4 * 1.6 in the parameter, is to make sure, that the chance for 2 is exactly 40%. We have 1/6 for each of the possible 6 numbers - [2,3,4,5,6,7]. Thus, the times when we do not enter in If rnd() <= priorityPercentage are also taken into account.
Whats the best way to round in VBA Access?
My current method utilizes the Excel method
Excel.WorksheetFunction.Round(...
But I am looking for a means that does not rely on Excel.
Be careful, the VBA Round function uses Banker's rounding, where it rounds .5 to an even number, like so:
Round (12.55, 1) would return 12.6 (rounds up)
Round (12.65, 1) would return 12.6 (rounds down)
Round (12.75, 1) would return 12.8 (rounds up)
Whereas the Excel Worksheet Function Round, always rounds .5 up.
I've done some tests and it looks like .5 up rounding (symmetric rounding) is also used by cell formatting, and also for Column Width rounding (when using the General Number format). The 'Precision as displayed' flag doesn't appear to do any rounding itself, it just uses the rounded result of the cell format.
I tried to implement the SymArith function from Microsoft in VBA for my rounding, but found that Fix has an error when you try to give it a number like 58.55; the function giving a result of 58.5 instead of 58.6. I then finally discovered that you can use the Excel Worksheet Round function, like so:
Application.Round(58.55, 1)
This will allow you to do normal rounding in VBA, though it may not be as quick as some custom function. I realize that this has come full circle from the question, but wanted to include it for completeness.
To expand a little on the accepted answer:
"The Round function performs round to even, which is different from round to larger."--Microsoft
Format always rounds up.
Debug.Print Round(19.955, 2)
'Answer: 19.95
Debug.Print Format(19.955, "#.00")
'Answer: 19.96
ACC2000: Rounding Errors When You Use Floating-Point Numbers: http://support.microsoft.com/kb/210423
ACC2000: How to Round a Number Up or Down by a Desired Increment: http://support.microsoft.com/kb/209996
Round Function: http://msdn2.microsoft.com/en-us/library/se6f2zfx.aspx
How To Implement Custom Rounding Procedures: http://support.microsoft.com/kb/196652
In Switzerland and in particulat in the insurance industry, we have to use several rounding rules, depending if it chash out, a benefit etc.
I currently use the function
Function roundit(value As Double, precision As Double) As Double
roundit = Int(value / precision + 0.5) * precision
End Function
which seems to work fine
Int and Fix are both useful rounding functions, which give you the integer part of a number.
Int always rounds down - Int(3.5) = 3, Int(-3.5) = -4
Fix always rounds towards zero - Fix(3.5) = 3, Fix(-3.5) = -3
There's also the coercion functions, in particular CInt and CLng, which try to coerce a number to an integer type or a long type (integers are between -32,768 and 32,767, longs are between-2,147,483,648 and 2,147,483,647). These will both round towards the nearest whole number, rounding away from zero from .5 - CInt(3.5) = 4, Cint(3.49) = 3, CInt(-3.5) = -4, etc.
1 place = INT(number x 10 + .5)/10
3 places = INT(number x 1000 + .5)/1000
and so on.You'll often find that apparently kludgy solutions like this are much faster than using Excel functions, because VBA seems to operate in a different memory space.
eg If A > B Then MaxAB = A Else MaxAB = B is about 40 x faster than using ExcelWorksheetFunction.Max
Unfortunately, the native functions of VBA that can perform rounding are either missing, limited, inaccurate, or buggy, and each addresses only a single rounding method. The upside is that they are fast, and that may in some situations be important.
However, often precision is mandatory, and with the speed of computers today, a little slower processing will hardly be noticed, indeed not for processing of single values. All the functions at the links below run at about 1 µs.
The complete set of functions - for all common rounding methods, all data types of VBA, for any value, and not returning unexpected values - can be found here:
Rounding values up, down, by 4/5, or to significant figures (EE)
or here:
Rounding values up, down, by 4/5, or to significant figures (CodePlex)
Code only at GitHub:
VBA.Round
They cover the normal rounding methods:
Round down, with the option to round negative values towards zero
Round up, with the option to round negative values away from zero
Round by 4/5, either away from zero or to even (Banker's Rounding)
Round to a count of significant figures
The first three functions accept all the numeric data types, while the last exists in three varieties - for Currency, Decimal, and Double respectively.
They all accept a specified count of decimals - including a negative count which will round to tens, hundreds, etc. Those with Variant as return type will return Null for incomprehensible input
A test module for test and validating is included as well.
An example is here - for the common 4/5 rounding. Please study the in-line comments for the subtle details and the way CDec is used to avoid bit errors.
' Common constants.
'
Public Const Base10 As Double = 10
' Rounds Value by 4/5 with count of decimals as specified with parameter NumDigitsAfterDecimals.
'
' Rounds to integer if NumDigitsAfterDecimals is zero.
'
' Rounds correctly Value until max/min value limited by a Scaling of 10
' raised to the power of (the number of decimals).
'
' Uses CDec() for correcting bit errors of reals.
'
' Execution time is about 1µs.
'
Public Function RoundMid( _
ByVal Value As Variant, _
Optional ByVal NumDigitsAfterDecimals As Long, _
Optional ByVal MidwayRoundingToEven As Boolean) _
As Variant
Dim Scaling As Variant
Dim Half As Variant
Dim ScaledValue As Variant
Dim ReturnValue As Variant
' Only round if Value is numeric and ReturnValue can be different from zero.
If Not IsNumeric(Value) Then
' Nothing to do.
ReturnValue = Null
ElseIf Value = 0 Then
' Nothing to round.
' Return Value as is.
ReturnValue = Value
Else
Scaling = CDec(Base10 ^ NumDigitsAfterDecimals)
If Scaling = 0 Then
' A very large value for Digits has minimized scaling.
' Return Value as is.
ReturnValue = Value
ElseIf MidwayRoundingToEven Then
' Banker's rounding.
If Scaling = 1 Then
ReturnValue = Round(Value)
Else
' First try with conversion to Decimal to avoid bit errors for some reals like 32.675.
' Very large values for NumDigitsAfterDecimals can cause an out-of-range error
' when dividing.
On Error Resume Next
ScaledValue = Round(CDec(Value) * Scaling)
ReturnValue = ScaledValue / Scaling
If Err.Number <> 0 Then
' Decimal overflow.
' Round Value without conversion to Decimal.
ReturnValue = Round(Value * Scaling) / Scaling
End If
End If
Else
' Standard 4/5 rounding.
' Very large values for NumDigitsAfterDecimals can cause an out-of-range error
' when dividing.
On Error Resume Next
Half = CDec(0.5)
If Value > 0 Then
ScaledValue = Int(CDec(Value) * Scaling + Half)
Else
ScaledValue = -Int(-CDec(Value) * Scaling + Half)
End If
ReturnValue = ScaledValue / Scaling
If Err.Number <> 0 Then
' Decimal overflow.
' Round Value without conversion to Decimal.
Half = CDbl(0.5)
If Value > 0 Then
ScaledValue = Int(Value * Scaling + Half)
Else
ScaledValue = -Int(-Value * Scaling + Half)
End If
ReturnValue = ScaledValue / Scaling
End If
End If
If Err.Number <> 0 Then
' Rounding failed because values are near one of the boundaries of type Double.
' Return value as is.
ReturnValue = Value
End If
End If
RoundMid = ReturnValue
End Function
If you're talking about rounding to an integer value (and not rounding to n decimal places), there's always the old school way:
return int(var + 0.5)
(You can make this work for n decimal places too, but it starts to get a bit messy)
Lance already mentioned the inherit rounding bug in VBA's implementation.
So I need a real rounding function in a VB6 app.
Here is one that I'm using. It is based on one I found on the web as is indicated in the comments.
' -----------------------------------------------------------------------------
' RoundPenny
'
' Description:
' rounds currency amount to nearest penny
'
' Arguments:
' strCurrency - string representation of currency value
'
' Dependencies:
'
' Notes:
' based on RoundNear found here:
' http://advisor.com/doc/08884
'
' History:
' 04/14/2005 - WSR : created
'
Function RoundPenny(ByVal strCurrency As String) As Currency
Dim mnyDollars As Variant
Dim decCents As Variant
Dim decRight As Variant
Dim lngDecPos As Long
1 On Error GoTo RoundPenny_Error
' find decimal point
2 lngDecPos = InStr(1, strCurrency, ".")
' if there is a decimal point
3 If lngDecPos > 0 Then
' take everything before decimal as dollars
4 mnyDollars = CCur(Mid(strCurrency, 1, lngDecPos - 1))
' get amount after decimal point and multiply by 100 so cents is before decimal point
5 decRight = CDec(CDec(Mid(strCurrency, lngDecPos)) / 0.01)
' get cents by getting integer portion
6 decCents = Int(decRight)
' get leftover
7 decRight = CDec(decRight - decCents)
' if leftover is equal to or above round threshold
8 If decRight >= 0.5 Then
9 RoundPenny = mnyDollars + ((decCents + 1) * 0.01)
' if leftover is less than round threshold
10 Else
11 RoundPenny = mnyDollars + (decCents * 0.01)
12 End If
' if there is no decimal point
13 Else
' return it
14 RoundPenny = CCur(strCurrency)
15 End If
16 Exit Function
RoundPenny_Error:
17 Select Case Err.Number
Case 6
18 Err.Raise vbObjectError + 334, c_strComponent & ".RoundPenny", "Number '" & strCurrency & "' is too big to represent as a currency value."
19 Case Else
20 DisplayError c_strComponent, "RoundPenny"
21 End Select
End Function
' -----------------------------------------------------------------------------
VBA.Round(1.23342, 2) // will return 1.23
To solve the problem of penny splits not adding up to the amount that they were originally split from, I created a user defined function.
Function PennySplitR(amount As Double, Optional splitRange As Variant, Optional index As Integer = 0, Optional n As Integer = 0, Optional flip As Boolean = False) As Double
' This Excel function takes either a range or an index to calculate how to "evenly" split up dollar amounts
' when each split amount must be in pennies. The amounts might vary by a penny but the total of all the
' splits will add up to the input amount.
' Splits a dollar amount up either over a range or by index
' Example for passing a range: set range $I$18:$K$21 to =PennySplitR($E$15,$I$18:$K$21) where $E$15 is the amount and $I$18:$K$21 is the range
' it is intended that the element calling this function will be in the range
' or to use an index and total items instead of a range: =PennySplitR($E$15,,index,N)
' The flip argument is to swap rows and columns in calculating the index for the element in the range.
' Thanks to: http://stackoverflow.com/questions/5559279/excel-cell-from-which-a-function-is-called for the application.caller.row hint.
Dim evenSplit As Double, spCols As Integer, spRows As Integer
If (index = 0 Or n = 0) Then
spRows = splitRange.Rows.count
spCols = splitRange.Columns.count
n = spCols * spRows
If (flip = False) Then
index = (Application.Caller.Row - splitRange.Cells.Row) * spCols + Application.Caller.Column - splitRange.Cells.Column + 1
Else
index = (Application.Caller.Column - splitRange.Cells.Column) * spRows + Application.Caller.Row - splitRange.Cells.Row + 1
End If
End If
If (n < 1) Then
PennySplitR = 0
Return
Else
evenSplit = amount / n
If (index = 1) Then
PennySplitR = Round(evenSplit, 2)
Else
PennySplitR = Round(evenSplit * index, 2) - Round(evenSplit * (index - 1), 2)
End If
End If
End Function
I used the following simple function to round my currencies as in our company we always round up.
Function RoundUp(Number As Variant)
RoundUp = Int(-100 * Number) / -100
If Round(Number, 2) = Number Then RoundUp = Number
End Function
but this will ALWAYS round up to 2 decimals and may also error.
even if it is negative it will round up (-1.011 will be -1.01 and 1.011 will be 1.02)
so to provide more options for rounding up (or down for negative) you could use this function:
Function RoundUp(Number As Variant, Optional RoundDownIfNegative As Boolean = False)
On Error GoTo err
If Number = 0 Then
err:
RoundUp = 0
ElseIf RoundDownIfNegative And Number < 0 Then
RoundUp = -1 * Int(-100 * (-1 * Number)) / -100
Else
RoundUp = Int(-100 * Number) / -100
End If
If Round(Number, 2) = Number Then RoundUp = Number
End Function
(used in a module, if it isn't obvious)
Here is easy way to always round up to next whole number in Access 2003:
BillWt = IIf([Weight]-Int([Weight])=0,[Weight],Int([Weight])+1)
For example:
[Weight] = 5.33 ; Int([Weight]) = 5 ; so 5.33-5 = 0.33 (<>0), so answer is BillWt = 5+1 = 6.
[Weight] = 6.000, Int([Weight]) = 6 , so 6.000-6 = 0, so answer is BillWt = 6.
Public Function RoundUpDown(value, decimals, updown)
If IsNumeric(value) Then
rValue = Round(value, decimals)
rDec = 10 ^ (-(decimals))
rDif = rValue - value
If updown = "down" Then 'rounding for "down" explicitly.
If rDif > 0 Then ' if the difference is more than 0, it rounded up.
RoundUpDown = rValue - rDec
ElseIf rDif < 0 Then ' if the difference is less than 0, it rounded down.
RoundUpDown = rValue
Else
RoundUpDown = rValue
End If
Else 'rounding for anything thats not "down"
If rDif > 0 Then ' if the difference is more than 0, it rounded up.
RoundUpDown = rValue
ElseIf rDif < 0 Then ' if the difference is less than 0, it rounded down.
RoundUpDown = rValue + rDec
Else
RoundUpDown = rValue
End If
End If
End If
'RoundUpDown(value, decimals, updown) 'where updown is "down" if down. else rounds up. put this in your program.
End Function