I had to write a function that takes a value (qty) and then determines the range it falls in, and determines the price based off of that range.
So if 1-10 is passed in, the price is $2, if 11-20, the price is $4. Etc etc etc. And this had to be fairly unlimited, because this is being used on an eCommerce site to determine checkout shipping cost.
My question is if there is a more efficient way to do this, rather than having a loop to 10,000 that builds an array by 10's, and then loop through the array that I have made to determine the range of the value passed in.
function getPrice(qty)
tempArray = array()
for i = 0 to 10000 step 10
addArrayItem tempArray,i
next
if qty > 9 then
for i = 0 to ubound(tempArray)
if cInt(qty) > tempArray(i) AND cInt(qty) <= tempArray(i+1) then
response.write("falls in range " & tempArray(i) + 1 & " through " & tempArray(i+1) & "<br>")
temp = left(tempArray(i+1),len(tempArray(i+1)) - 1)
rate = formatcurrency(cInt(temp * 2),2)
exit for
end if
next
elseif qty > 0 then
rate = "$2.00"
else
rate = "error"
end if
getPrice = rate
end function
sub addArrayItem(ByRef ar,ByVal count)
ub = uBound(ar)
reDim preserve ar(ub + 1)
ar(ub+1) = count
end sub
Related
I am currently attempting optimise a set of 4 variables which can have any value between 0.01 and 0.97, the total of these 4 variables must equal 1. Eventually these 4 variables will need to be entered into the spreadsheet in order to return an output (this is a cell in the spreadsheet), ideally I would like to store this output against the 4 inputted variables.
My first step was to attempt to find all the combinations possible; I did this in a very basic form which took over an hour and returned around 150,000 rows.
Next I attempted to store the variables in a class before adding them to a collection but this was still quite slow.
My next step was to add them into a multi dimensional array but this was just as slow as the collection method.
I have already added Application.ScreenUpdating = False and found that Application.Calculation = xlManual made no difference in this case.
Does anyone have any advice on how to make this quicker?
This would need to be repeated a fair amount so ideally wouldn't take an hour to produce all the combinations. I haven't included the part about getting an output as the first step is way too slow and storing those results will use the same process as getting the combinations. I added the secondselapsed after the 3rd next as this takes about 32 seconds and is easier to test with.
My code example using arrays is here:
Sub WDLPerfA()
StartTime = Timer
Application.ScreenUpdating = False
NoRows = 0
Dim combos()
ReDim combos(NoRows, 1)
'Looping through variables
For a = 1 To 97
For b = 1 To 97
For c = 1 To 97
For d = 1 To 97
Application.ScreenUpdating = False
Total = a + b + c + d
If Total = 100 Then
If NoRows = 0 Then GoTo Line1
ElseIf NoRows > 0 Then
NoRows = NoRows + 1
ReDim combos(NoRows, 1)
Line1:
combo = a & "," & b & "," & c & "," & d
combos(NoRows, 0) = combo
Else: GoTo Line2
End If
Line2:
Next
Next
Next
SecondsElapsed = Round(Timer - StartTime, 2)
Debug.Print SecondsElapsed
Next
End Sub
As an test, I used a Collection to capture all of the combinations to add up to your target value and then stored all those combinations on a worksheet. It didn't take anywhere near an hour.
You don't need GoTo and you don't need to disable ScreenUpdating. But you should always use Option Explicit (read this explanation for why).
The combination loop test is simple:
Option Explicit
Sub FourCombos()
Const MAX_COUNT As Long = 97
Const TARGET_VALUE As Long = 100
Dim combos As Collection
Set combos = New Collection
Dim a As Long
Dim b As Long
Dim c As Long
Dim d As Long
StartCounter
For a = 1 To MAX_COUNT
For b = 1 To MAX_COUNT
For c = 1 To MAX_COUNT
For d = 1 To MAX_COUNT
If (a + b + c + d = TARGET_VALUE) Then
combos.Add a & "," & b & "," & c & "," & d
End If
Next d
Next c
Next b
Next a
Debug.Print "calc time elapsed = " & FormattedTimeElapsed()
Debug.Print "number of combos = " & combos.Count
Dim results As Variant
ReDim results(1 To combos.Count, 1 To 4)
StartCounter
For a = 1 To combos.Count
Dim combo As Variant
combo = Split(combos.Item(a), ",")
results(a, 1) = combo(0)
results(a, 2) = combo(1)
results(a, 3) = combo(2)
results(a, 4) = combo(3)
Next a
Sheet1.Range("A1").Resize(combos.Count, 4).Value = results
Debug.Print "results to sheet1 time elapsed = " & FormattedTimeElapsed()
End Sub
I used a high-performance timer in a separate module to measure the timing. On my system the results were
calc time elapsed = 1.774 seconds
number of combos = 156849
results to sheet1 time elapsed = 3.394 minutes
The timer code module is
Option Explicit
'------------------------------------------------------------------------------
' For Precision Counter methods
'
Private Type LargeInteger
lowpart As Long
highpart As Long
End Type
Private Declare Function QueryPerformanceCounter Lib _
"kernel32" (lpPerformanceCount As LargeInteger) As Long
Private Declare Function QueryPerformanceFrequency Lib _
"kernel32" (lpFrequency As LargeInteger) As Long
Private counterStart As LargeInteger
Private counterEnd As LargeInteger
Private crFrequency As Double
Private Const TWO_32 = 4294967296# ' = 256# * 256# * 256# * 256#
'==============================================================================
' Precision Timer Controls
' from: https://stackoverflow.com/a/198702/4717755
'
Private Function LI2Double(lgInt As LargeInteger) As Double
'--- converts LARGE_INTEGER to Double
Dim low As Double
low = lgInt.lowpart
If low < 0 Then
low = low + TWO_32
End If
LI2Double = lgInt.highpart * TWO_32 + low
End Function
Public Sub StartCounter()
'--- Captures the high precision counter value to use as a starting
' reference time.
Dim perfFrequency As LargeInteger
QueryPerformanceFrequency perfFrequency
crFrequency = LI2Double(perfFrequency)
QueryPerformanceCounter counterStart
End Sub
Public Function TimeElapsed() As Double
'--- Returns the time elapsed since the call to StartCounter in microseconds
If crFrequency = 0# Then
Err.Raise Number:=11, _
Description:="Must call 'StartCounter' in order to avoid " & _
"divide by zero errors."
End If
Dim crStart As Double
Dim crStop As Double
QueryPerformanceCounter counterEnd
crStart = LI2Double(counterStart)
crStop = LI2Double(counterEnd)
TimeElapsed = 1000# * (crStop - crStart) / crFrequency
End Function
Public Function FormattedTimeElapsed() As String
'--- returns the elapsed time value as above, but in a nicely formatted
' string in seconds, minutes, or hours
Dim result As String
Dim elapsed As Double
elapsed = TimeElapsed()
If elapsed <= 1000 Then
result = Format(elapsed, "0.000") & " microseconds"
ElseIf (elapsed > 1000) And (elapsed <= 60000) Then
result = Format(elapsed / 1000, "0.000") & " seconds"
ElseIf (elapsed > 60000) And (elapsed < 3600000) Then
result = Format(elapsed / 60000, "0.000") & " minutes"
Else
result = Format(elapsed / 3600000, "0.000") & " hours"
End If
FormattedTimeElapsed = result
End Function
If my input array is (10,10,20,20,30,30,40,40,50,50) I would like a simple piece of code that would return (1,2,3,4,5,6,7,8,9,10). I am trying to implement an ABC classification and I am currently using this code:
For i = 1 To noA 'noA number of items should be classified as "A"
'return the item number with the i'th largest number in arrTembABC
intTemp = Application.Match(WorksheetFunction.Large(arrTempABC, i), arrTempABC, True)
'assign the category "A" to 'intTemp' item number
SKUinfo(intTemp, 12) = "A"
Next i
'some printing code
The problem with the above code is that when there are duplicate values, it always returns the position of the first instance. Any other item number with the same value does not get assigned a category.
So for the array discussed above (see "avg value") the code only classifies the first instance of each duplicate value, and the rest are blank (see "ABC_CategCry")
I resorted to sorting the array that holds the values while holding their positions in a separate array. I post the entire sub below that does an ABC classification based either on volume or value (=avg volume*cost). I tried to comment in an informative way but appreciate any questions for clarification or comments on how to improve clarity.
Sub ABCclass(ByRef swtcABCclass As Integer, ByRef prcA As Double, ByRef prcB As Double, _
ByRef prcC As Double)
Dim arrTempABC() As Double, i As Integer, j As Integer, intTemp As Integer, tempABC As Double
Dim noA As Integer, noB As Integer, noC As Integer, arrTempTSno() As Integer
ReDim arrTempABC(1 To tsTot)
ReDim arrTempTSno(1 To tsTot)
'populate the array that holds the values by which we classify the SKUs
If swtcABCclass = 1 Then 'ABC based on volume*value
For i = 1 To tsTot
arrTempABC(i) = SKUinfo(i, 11) * SKUinfo(i, 5) 'average monthly volume*value (cost)
arrTempTSno(i) = i 'just hold the position (ascending number of the timeseries/SKU)
Next i
ElseIf swtcABCclass = 2 Then 'ABC based on volume
For i = 1 To tsTot
arrTempABC(i) = SKUinfo(i, 11) ' average monthly volume
arrTempTSno(i) = i
Next i
End If
'find the limits of each class (in terms of percentages of SKUbase)
noA = WorksheetFunction.RoundDown(tsTot * prcA, 0) 'first prcA% of the tsTot (number of timeseries or SKUs) are in class A
noB = noA + WorksheetFunction.RoundDown(tsTot * prcB, 0)
noC = tsTot
'sort arrTempABC while saving the positions in a seperate array
For i = 2 To tsTot
tempABC = arrTempABC(i)
intTemp = arrTempTSno(i)
For j = i - 1 To 1 Step -1
If arrTempABC(j) >= tempABC Then Exit For
arrTempABC(j + 1) = arrTempABC(j)
arrTempTSno(j + 1) = arrTempTSno(j)
Next
arrTempABC(j + 1) = tempABC
arrTempTSno(j + 1) = intTemp
Next
'now that i have the sorted positions, i can just assign the categories
For i = 1 To noA 'noa number of items should be classified as "A"
SKUinfo(arrTempTSno(i), 12) = "A"
Next i
For i = noA + 1 To noB 'nob - (noa +1) number of items should be classified as "B"
SKUinfo(arrTempTSno(i), 12) = "B"
Next i
For i = noB + 1 To noC 'noc - (nob +1) number of items should be classified as "C"
SKUinfo(arrTempTSno(i), 12) = "C"
Next i
End Sub
This is my first post. I have been using VBA for a month now, and I am trying to populate an array with dates based on a user defined range. For example, the user will input: 05/01/2001 - 05/21/2001. There for I am trying to populate an array with all of the days from start to end, with this example it will be 21 dates. When I print out the array, I am only getting the odd days, and not the even days. Can anyone help with this? Thanks!
I am usind the DateDiff() function to get the number of days between the start and end dates to determine the number of dates I have to include inside of the array.
temp_csv_file_count is the number of values inside the array, input_start_date and input_end_date are strings, ignore the state, that has to do with something else.
temp_csv_file_count = DateDiff("d", input_start_date, input_end_date)
temp_csv_file_count = temp_csv_file_count + 1
Dim temp_date() As String
ReDim temp_date(0 To temp_csv_file_count) As String
Dim i As Integer
For i = 0 To temp_csv_file_count
temp_date(i) = DateAdd("d", i, input_start_date)
i = i + 1
Next i
msg = "File Count: " & temp_csv_file_count & ", State: " & temp_state
MsgBox msg
Dim array_contents As String
Dim j As Integer
For j = 0 To temp_csv_file_count
array_contents = array_contents + temp_date(j) + vbNewLine
Next j
MsgBox "the values of my dynamic array are: " & vbNewLine & array_contents
Actual:
05/01/2001,
05/03/2001,
05/05/2001,
05/07/2001,
05/09/2001,
05/11/2001,
05/13/2001,
05/15/2001,
05/17/2001,
05/19/2001,
05/21/2001
For i = 0 To temp_csv_file_count
temp_date(i) = DateAdd("d", i, input_start_date)
'i = i + 1 'THIS IS WHY
Next i
A for loop will iterate 1 at a time, unless specified in the Step (you haven't listed the step, so it assumes 1), you are telling it to add 1 before the loop itself iterates (via Next i).
For i = 0 To temp_csv_file_count Step 1 'added the step to ensure it is understood
temp_date(i) = DateAdd("d", i, input_start_date)
Next i
For-each loop each time increase the value of i by one (if you do not change it) by its self. There is no reason to use i = i + 1.
For further details:
If you want to increase the value of i by two you could use Step 2:
Example:
For i = 0 To temp_csv_file_count Step 2
temp_date(i) = DateAdd("d", i, input_start_date)
Next i
If you want to start the loop from the bottom to the top OR if loop aiming to delete:
Example:
For i = temp_csv_file_count To 0 Step -1
temp_date(i) = DateAdd("d", i, input_start_date)
Next i
I ran into the following issue when dealing with adding to variable array sizes. The loop runs one time more then it should essentially. But I'm curious as to what would cause this behavior? Am I not quite understanding how the loop exit functions are being called?
Here's the code:
Module Module1
Sub Main()
Dim num(-1)
Dim i = 0
Console.WriteLine("Input numbers to be added, q to stop:")
Dim input
Dim total = 0
Do
ReDim Preserve num(UBound(num) + 1) : num(UBound(num)) = i 'resize the array each time before an element is added.
input = Console.ReadLine
If IsNumeric(input) Then 'attempt to break loop on non numeric input
num(i) = CInt(input)
i += 1
Else
Exit Do
End If
Loop
total = 0
For Each n In num
total += n
Next
Console.WriteLine(Join(num))
Console.WriteLine("Total: " & total)
Console.ReadLine()
For input: 1 2 3 4 5 q, the output I get is:
1 2 3 4 5 5
Total: 20
It adds the last element twice, which is interesting as it is not only running twice but somehow using the last numeric input even though the final input was not numeric. Does anyone know why that would be?
You both (jnb92, PankajJaju) should not grow the array before you are sure the input is numerical and has to be stored.
Dim input
Do
input = Console.ReadLine()
If IsNumeric(input) Then 'attempt to break loop on non numeric input
ReDim Preserve num(UBound(num) + 1)
num(UBound(num)) = CInt(input)
Else
Exit Do
End If
Loop
Update wrt comment:
Your
ReDim Preserve num(UBound(num) + 1) : num(UBound(num)) = i
assigns i to num for each input; your
num(i) = CInt(input)
overwrites that with your numerical input, but not for the terminating "q". So for your (one and only?) test case, the spurious last elemement is (accidentially) 5.
I've used your script and tried to create a working solution
Dim num, input, total, i
num = Array()
i = 0
Do
input = Inputbox("Input numbers to be added, q to stop:")
If IsNumeric(input) Then 'attempt to break loop on non numeric input
ReDim Preserve num(UBound(num) + 1) 'resize the array each time before an element is added.
num(i) = CInt(input)
i = i + 1
Else
Exit Do
End If
Loop
total = 0
For Each n In num
total = total + n
Next
msgbox Join(num)
msgbox "Total: " & total
Edit - Updated answer based on #Ekkehard.Horner comments
The code below returns an array. I would like to use it in a spread sheet as an excel formula to return the array. However, when I do, it only returns the first value to the cell. Is there anyway to return the array in a range of equal size as the array?
Function LoadNumbers(Low As Long, High As Long) As Long()
'''''''''''''''''''''''''''''''''''''''
' Returns an array of Longs, containing
' the numbers from Low to High. The
' number of elements in the returned
' array will vary depending on the
' values of Low and High.
''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''
' Declare ResultArray as a dynamic array
' to be resized based on the values of
' Low and High.
'''''''''''''''''''''''''''''''''''''''''
Dim ResultArray() As Long
Dim Ndx As Long
Dim Val As Long
'''''''''''''''''''''''''''''''''''''''''
' Ensure Low <= High
'''''''''''''''''''''''''''''''''''''''''
If Low > High Then
Exit Function
End If
'''''''''''''''''''''''''''''''''''''''''
' Resize the array
'''''''''''''''''''''''''''''''''''''''''
ReDim ResultArray(1 To (High - Low + 1))
''''''''''''''''''''''''''''''''''''''''
' Fill the array with values.
''''''''''''''''''''''''''''''''''''''''
Val = Low
For Ndx = LBound(ResultArray) To UBound(ResultArray)
ResultArray(Ndx) = Val
Val = Val + 1
Next Ndx
''''''''''''''''''''''''''''''''''''''''
' Return the array.
''''''''''''''''''''''''''''''''''''''''
LoadNumbers = ResultArray()
End Function
A UDF can certainly return an array, and your function works fine. Just select, e.g., range B2:D2, put =LoadNumbers(1, 3) into the formula bar, and hit Ctrl+Shift+Enter to tell Excel it's an array function.
Now, you can't have the UDF auto-resize the range it was called from according to its inputs (at least not without some ugly Application.OnTime hack), but you don't need to do that anyways. Just put the function in a 1000-cell-wide range to begin with, and have the UDF fill in the unused space with blank cells, like this:
Function LoadNumbers(ByVal Low As Long, ByVal High As Long) As Variant()
Dim ResultArray() As Variant
Dim Ndx As Long
Dim Val As Long
Dim SourceCols As Long
SourceCols = Application.Caller.Columns.Count
If Low > High Then
Exit Function
End If
If High - Low + 1 > SourceCols Then High = Low + SourceCols - 1
ReDim ResultArray(1 To SourceCols)
Val = Low
For Ndx = LBound(ResultArray) To (High - Low + 1)
ResultArray(Ndx) = Val
Val = Val + 1
Next Ndx
For Ndx = (High - Low + 2) To UBound(ResultArray)
ResultArray(Ndx) = vbNullString
Next Ndx
LoadNumbers = ResultArray()
End Function
A worksheet formula can only output a value to the same cell the formula was written in. As it stands, the code already produces an array. If you want the values to be shown as you copy the formula down, use a formula like this (in any cell you want) and then copy down:
=INDEX(LoadNumbers(1,10),ROWS($A$1:$A1))
If you copy down too far, you'll get a #REF! error because the LoadNumbers ran out of numbers.
I was looking for something similar (create a function in a macro, take inputs from a sheet, output an multi-dim array), and I hope my use-case below helps to answer. If not, my apologies:
Use-case:
Create and apply well-known numerical option valuation function, and output the stock price, valuation, and payoff as a 3-D array (3 columns) of #rows as specified in the function (20 in this case, as NAS variable). The code is copied - but the idea is to get the output into the sheet....
a) These inputs are static in the sheet.
b) I called the macro formula 'optval' via the 'fx' function list from an output cell I wanted to start in, and put the starting inputs into the formula.
b) The output will propagate to the cells as per the code using the NAS bound of 20 rows. Trivial, but it works.
c) you can automate the execution of this and output to the sheet - but anyhow, I hope this way helps anyway.
The module function is below (copied!) - but just put the starter inputs in i.e.
Vol=.2, Int rate = 0.05, Strike=120, Exp = 1, P type = C (or P), US?= N, i.e. european, , NAS=20 (or however many rows you want to see, and it affects the granularity of the numerical method)
Function optval(Vol, Intrate, Strike, Expn, Ptype, Etype, NAS)
ReDim S(0 To NAS) As Double
ReDim VOld(0 To NAS) As Double
ReDim VNew(0 To NAS) As Double
ReDim dummy(0 To NAS, 1 To 3)
dS = 2 * Strike / NAS
dt = 0.9 / NAS / NAS / Vol / Vol
NTS = Int(Expn / dt) + 1
dt = Expn / NTS
q = 1
If Ptype = "P" Then q = -1
For i = 0 To NAS
S(i) = i * dS
VOld(i) = Application.Max(q * (S(i) - Strike), 0)
dummy(i, 1) = S(i)
dummy(i, 2) = VOld(i) 'Payoff
Next i
For k = 1 To NTS
For i = 1 To NAS - 1
Delta = (VOld(i + 1) - VOld(i - 1)) / 2 / dS
Gamma = (VOld(i + 1) - 2 * VOld(i) + VOld(i - 1)) / dS / dS
Theta = -0.5 * Vol * Vol * S(i) * S(i) * Gamma - _
Intrate * S(i) * Delta + Intrate * VOld(i)
VNew(i) = VOld(i) - Theta * dt 'BSE
Next i
VNew(0) = VOld(0) * (1 - Intrate * dt) 'S=0
VNew(NAS) = 2 * VNew(NAS - 1) - VNew(NAS - 2) 'Infty
For i = 0 To NAS
VOld(i) = VNew(i)
Next i
If Etype = "Y" Then
For i = 0 To NAS
VOld(i) = Application.Max(VOld(i), dummy(i, 2))
Next i
End If
Next k
For i = 0 To NAS
dummy(i, 3) = VOld(i)
Next i
optval = dummy
End Function
=INDEX(LoadNumbers(1,10),ROWS($A$1:$A1),COLUMNS($B$1,B$1))