I am presently trying to write a script that would pull a random meal from a list of meals and input them in a calendar. It generates 4 weeks (Sunday through Saturday), with two different meals per week. I would like to have it check each time it pulls a random meal from the list against the meals that it has already pulled to prevent the same meal from coming up twice in one month. Following is what I have written:
Dim ranDnr As Integer
Dim ranDnr2 As Integer
Dim usdMls(3) As Integer
Dim usdMls2(3) As Integer
Sub GnrtMlsMnthClndr()
Randomize
For i = 0 To 3
For j = 0 To 3
For x = 2 To 17 Step 5
For y = 2 To 17 Step 5
ranDnr = Int(60 * Rnd + 1)
While IsInArray(ByVal ranDnr, ByVal usdMls) = True
ranDnr = Int(60 * Rnd + 1)
Wend
usdMls(i) = ranDnr
Worksheets("Sheet1").Cells(x, 1) = Worksheets("Sheet2").Cells(ranDnr, 1)
ranDnr2 = Int(60 * Rnd + 1)
While IsInArray2(ByVal ranDnr2, ByVal usdMls2) = True
ranDnr2 = Int(60 * Rnd + 1)
Wend
usdMls2(j) = ranDnr2
Worksheets("Sheet1").Cells(x, 9) = Worksheets("Sheet2").Cells(ranDnr2, 1)
Next y
Next x
Next j
Next i
End Sub
Public Function IsInArray(ByVal ranDnr, ByVal usdMls) As Boolean
'Dim i
For i = 0 To 3
If usdMls(i) = ranDnr Then
IsInArray = True
Exit Function
End If
Next i
IsInArray = False
End Function
Public Function IsInArray2(ByVal ranDnr2, ByVal usdMls2) As Boolean
'Dim i
For i = 0 To 3
If usdMls2(i) = ranDnr2 Then
IsInArray2 = True
Exit Function
End If
Next i
IsInArray2 = False
End Function
I am really inexperienced in VBA and have absolutely no idea why this doesn't work, as it seems logical to me and doesn't generate any errors when I run it. Any assistance that could be provided would be appreciated.
Related
I am trying to create a function that finds the mean of the last d days from an array. My array is a time series with dates as col1 and prices as col2.
I want my function to be to allow the user to select the range, enter the number of days in past he wants the mean, and a Boolean whether the data is ascending or descending. if the number of elements in the series doesn't match d, example mean of 32 + "" then the function returns 0.
the Problem i am having is when i want to use the drag down in excel to fill the rest of the columns, the function doesn't work. for example for the sorted array; it takes mean of 56 + 34, then using drag down in excel the second cell should be the mean of 34 + 22 except it returns 0 and so on..
Function meanby(x As Range, d As Integer, sortarr As Boolean) As Double
Dim arr() As Variant
Dim i As Integer
Dim j As Integer
Dim count As Integer
Dim total As Double
Dim n As Integer
Dim temp As Variant
Dim arr2 As Variant
arr = rgntoarr(x)
n = x.Rows.count
If sortarr = False Then
For i = 1 To n / 2
temp = arr(i, 2)
arr(i, 2) = arr(n - i + 1, 2)
arr(n - i + 1, 2) = temp
Next i
End If
arr2 = arr
For j = 1 To d
total = total + arr2(j, 2)
If arr2(j, 2) = "" Then
Exit For
End If
i = i + 1
count = count + 1
Next j
If count < d Then
meanby = 0
Else
meanby = total / count
End If
End Function
I have a code where I'm adding last rows to collection which should be later transformed to an array and final step is to get last row with the least number of cells in it.
My current code is:
Dim lastc, lastc2, lastr, FindColNumber, FindColNumber2 as Long
Dim FindCol as Range
Dim col As New Collection
Dim CollectionToArray As Variant
Set FindCol = 1 'example
FindColNumber = FindCol.Column
lastc = FindColNumber + 1
Set FindCol2 = 5 'example
FindColNumber = FindCol2.Column
lastc2 = FindColNumber - 1
For R = lastc2 To lastc Step -1
lastc2 = R
col.Add Cells(ws.Rows.count, R).End(xlUp).Row
Next R
Debug.Print WorksheetFunction.Min(CollectionToArray(col))
Public Function CollectionToArray(myCol As Collection) As Variant
Dim result As Variant
Dim cnt As Long
ReDim result(myCol.count - 1)
For cnt = 0 To myCol.count - 1
result(cnt) = myCol(cnt + 1)
Next cnt
CollectionToArray = result
End Function
I am still getting Type Mismatch error and when hovering over CollectionToArray(Col)) I see "Object variable or With block variable not set".
Thank you.
I think this is my first question in this forum, so excuse me if I miss following some rules. I am trying to write a VBA algorithm to compute the Shapley-Shubik index. This index requires to compute all the permutations of a sequence of numbers (which represent the votes in a parliament, congress, etc.). After some thorough research I understood that one must use a recursive algorithm to perform such thing.
My idea is to create a matrix in vba where each element is stored separately, and each row contains a different permutation. That is the only way I can subsequently perform computations and retrieve the correct label values needed to compute such index.
The problem is I cannot understand how to revert back to the previous levels once I reach the last level of recursion.
(EDIT) Eventually, I was able to come up with a solution. I am posting the results below, since I have seen that it has been asked for. I should warn though, this is a very inefficient code, and it does not work with more than 7 players. The reason for this is because vba is not able to deal with the extremely big matrix created by this code, so the program just crashes with an overflow error.
However, in have not been particularly smart in writing this code, this means it should be pretty easy to modify the code in order to make it work for a bigger number of players. Basically, instead of using the permutation function to create a matrix, one just needs to compute the pivotal player in each specific permutation, then use an array to "store" the frequencies. Unfortunately, I did not have time to modify the code, as I am currently working on other projects, though somewhat related, using Matlab instead.
Here it is the function I have assembled:
Public Function ShapleyShubik( _
Votes As Range, _
Coalitions As Range, _
Candidate As String, _
Threshold As Double) As Double
'
'------------------------------------------------------
' by Sim1
' This function computes the Shapley-Shubik Power Index
' For a specified coalition among the available ones
'------------------------------------------------------
'
Dim Labels() As String
Dim Powers() As Double
Dim Interval As Variant
Dim MatLabels() As String
Dim MatPowers() As Integer
Dim Calc() As String
Dim Total As Integer
Dim ii As Integer
'Convert Labels Range
Interval = ToArray(Coalitions)
ReDim Labels(1 To UBound(Interval)) As String
For ii = 1 To UBound(Interval)
Labels(ii) = CStr(Interval(ii))
Next
'Convert Powers Range
Interval = ToArray(Votes)
ReDim Powers(1 To UBound(Interval)) As Double
For ii = 1 To UBound(Interval)
Powers(ii) = CInt(Interval(ii))
Next
SShubCalc Powers, Labels, Calc, Threshold, Total
'Compute Index
ShapleyShubik = (UBound(Filter(Calc, Candidate, True)) + 1) / Total
End Function
Private Function SShubCalc( _
ByRef Powers() As Double, _
ByRef Labels() As String, _
ByRef Pivotal() As String, _
ByVal bar As Double, _
ByRef Righe As Integer) As Boolean
On Error GoTo Error_line
Dim Colonne As Integer
Dim MatNum() As Double
Dim MatStr() As String
Dim Threshold As Integer
Dim Somma() As Double
Dim perfsum() As Boolean
Dim PivPos() As Integer
Dim Addend() As Double
Dim v() As Variant
' Define Size Variables
Colonne = UBound(Powers)
Righe = Factorial(Colonne)
'Generate Matrix of Permutations
MatrPerm Powers, MatNum, Labels, MatStr
'Provide Vector Sums and Check Threshold
With Application.WorksheetFunction
Threshold = .Sum(.index(MatNum, 1))
End With
'Control for unanimity
If (Threshold * bar) < (Threshold - 1) Then
Threshold = Round(Threshold * bar, 0) + 1
End If
'Initialize Arrays
ReDim perfsum(1 To Righe)
ReDim PivPos(1 To Righe)
ReDim Pivotal(1 To Righe)
For ii = 1 To Colonne
'First Iteration
If ii = 1 Then
v = Application.WorksheetFunction.index(MatNum, 0, ii)
ToDoubleArray Somma, v
Else:
v = Application.WorksheetFunction.index(MatNum, 0, (ii))
ToDoubleArray Addend, v
SumVector Somma, Somma, Addend
End If
For j = 1 To Righe
If Somma(j) >= Threshold And perfsum(j) = False Then
PivPos(j) = ii
perfsum(j) = True
End If
Next j
Next ii
'Transfer PivoPos to Labels
For ii = 1 To Righe
Pivotal(ii) = MatStr(ii, PivPos(ii))
Next ii
SShubCalc = True
Exit Function
Error_line:
SShubCalc = False
End Function
Private Function nextPerm(s As String)
' inspired by http://stackoverflow.com/questions/352203/generating-permutations-lazily
' this produces the "next" permutation
' it allows one to step through all possible iterations without having to have them
' all in memory at the same time
Dim L As Integer, ii As Integer, jj As Integer
Dim c() As Byte, temp As Byte
L = Len(s)
If StrComp(s, "**done**") = 0 Or StrComp(s, "") = 0 Then
nextPerm = ""
Exit Function
End If
' convert to byte array... more compact to manipulate
ReDim c(1 To L)
For ii = 1 To L
c(ii) = Asc(Mid(s, ii, 1))
Next ii
' find the largest "tail":
For ii = L - 1 To 1 Step -1
If c(ii) < c(ii + 1) Then Exit For
Next ii
' if we complete the loop without break, ii will be zero
If ii = 0 Then
nextPerm = "**done**"
Exit Function
End If
' find the smallest value in the tail that is larger than c(ii)
' take advantage of the fact that tail is sorted in reverse order
For jj = L To ii + 1 Step -1
If c(jj) > c(ii) Then
' swap elements
temp = c(jj)
c(jj) = c(ii)
c(ii) = temp
Exit For
End If
Next jj
' now reverse the characters from ii+1 to the end:
nextPerm = ""
For jj = 1 To ii
nextPerm = nextPerm & Chr(c(jj))
Next jj
For jj = L To ii + 1 Step -1
nextPerm = nextPerm & Chr(c(jj))
Next jj
'Debug.Print nextPerm
End Function
Private Function Factorial(dblNumber As Integer) As Integer
Dim dblCtr As Double
Dim dblResult As Double
dblResult = 1 'initializes variable
For dblCtr = 1 To dblNumber
dblResult = dblResult * dblCtr
Next dblCtr
Factorial = dblResult
End Function
Private Function SumVector(ByRef Result() As Double, ByRef Vec1() As Double, ByRef Vec2() As Double)
Dim temp As Integer
Dim tempuno As Integer
Dim ii As Integer
If LBound(Vec1) = 0 Then
temp = UBound(Vec2)
ReDim Preserve Vec1(1 To (temp + 1))
End If
If LBound(Vec2) = 0 Then
tempuno = UBound(Vec2)
ReDim Preserve Vec2(1 To (temp + 1))
End If
If temp <> tempuno Then
Exit Function
End If
ReDim Preserve Result(1 To UBound(Vec1))
'Debug.Print Vec1(1, 1)
For ii = 1 To UBound(Vec1)
Result(ii) = Vec1(ii) + Vec2(ii)
Next ii
End Function
Private Function ToDoubleArray( _
ByRef DoubleArray() As Double, _
ByRef VariantArray() As Variant)
If LBound(VariantArray) = 0 Then
ReDim Preserve VariantArray(1 To (UBound(VariantArray) + 1))
End If
ReDim DoubleArray(1 To UBound(VariantArray))
For ii = 1 To UBound(VariantArray)
DoubleArray(ii) = VariantArray(ii, 1)
Next ii
End Function
Private Function MatrPermStr( _
ByRef VecInput() As String, _
ByRef MatOutput() As String)
Dim Sequence As String
Dim StrPerm As String
Dim Colonne As Integer
Dim Righe As Integer
Dim ii As Integer
Dim j As Integer
' Size Variables
Colonne = UBound(VecInput)
Righe = Factorial(Colonne)
ReDim MatOutput(1 To Righe, 1 To Colonne) As String
'Start With an Empty Sequence
Sequence = ""
'Create Sequence with defined Length
For ii = 1 To Colonne
Sequence = Sequence & ii
Next ii
'Assign the permutation to the array
For j = 1 To Righe
If j = 1 Then
StrPerm = Sequence
Else
StrPerm = nextPerm(StrPerm)
End If
For ii = 1 To Colonne
MatOutput(j, ii) = VecInput(Mid(StrPerm, ii, 1))
Next ii
Next j
End Function
Private Function MatrPerm( _
ByRef VecInput() As Double, _
ByRef MatOutput() As Double, _
ByRef VecInputStr() As String, _
ByRef MatOutputStr() As String)
Dim Sequence As String
Dim StrPerm As String
Dim Colonne As Integer
Dim Righe As Integer
Dim ii As Integer
Dim j As Integer
Dim t As Integer
' Size Variables
Colonne = UBound(VecInput)
Righe = Factorial(Colonne)
ReDim MatOutput(1 To Righe, 1 To Colonne)
ReDim MatOutputStr(1 To Righe, 1 To Colonne)
'Start With an Empty Sequence
Sequence = ""
'Create Sequence with defined Length
For ii = 1 To Colonne
Sequence = Sequence & ii
Next ii
'Assign the permutation to the array
For j = 1 To Righe
If j = 1 Then
StrPerm = Sequence
Else
StrPerm = nextPerm(StrPerm)
End If
For ii = 1 To Colonne
MatOutput(j, ii) = VecInput(Mid(StrPerm, ii, 1))
MatOutputStr(j, ii) = VecInputStr(Mid(StrPerm, ii, 1))
Next ii
Next j
End Function
Private Function ToArray(ByRef someRange As Range) As Variant
Dim someValues As Variant
With someRange
If .Cells.Count = 1 Then
ReDim someValues(1 To 1)
someValues(1) = someRange.Value
ElseIf .Rows.Count = 1 Then
someValues = Application.Transpose(Application.Transpose(someRange.Value))
ElseIf .Columns.Count = 1 Then
someValues = Application.Transpose(someRange.Value)
Else
MsgBox "someRange is mutil-dimensional"
End If
End With
ToArray = someValues
End Function
Private Sub DescribeShapShub()
Dim FuncName As String
Dim FuncDesc As String
Dim Category As String
Dim ArgDesc(1 To 4) As String
FuncName = "SHAPLEYSHUBIK"
FuncDesc = "Returns Shapley-Shubik power index for a given player, given the other players' votes"
Category = 3 'Math category
ArgDesc(1) = "Range containing the player's votes (Only selected votes will be considered in the computation)"
ArgDesc(2) = "Range containing the player's names (must have the same length as ""Votes"")"
ArgDesc(3) = "Cell or String containing the player for which to compute the index"
ArgDesc(4) = "Cell or Number containing the voting threshold (e.g. 0.5 for 50%)"
Application.MacroOptions _
Macro:=FuncName, _
Description:=FuncDesc, _
Category:=Category, _
ArgumentDescriptions:=ArgDesc
End Sub
Sorry if some variables are in Italian. Also, some parts of the code have been retrieved here and there in some specialised forums, so I take no credit for the specific commands, just for the assembling :)
One last request: if anyone is able to improve this code, please share it so everybody can use it.
I am not going to answer your question exactly; but I would like to offer you a nice little function that will help solve your bigger problem. This function generates the "next" permutation of a string - where the string can contain numbers or letters, and "next" is in a lexicographical sense (see [this discussion](Generating permutations lazily
)).
What can you do with it? Well, when you want to compute anything "over all possible permutations", having a function that gives you "just the next permutation" will keep your code readable (it takes away an awful lot of housekeeping!). You can then simply say (this is pseudocode):
// initialize stuff
firstPerm = "1234"
np = nextPerm(firstPerm)
// loop over all permutations
while not np equals "done"
// update calculations on np
np = nextPerm(np)
wend
// report your results
Here is the function. It seemed to behave itself for me - even when I have multiple identical characters in the string, or a mixture of letters and numbers. Note that it treats A and a as distinct... Also note that it returns the string "done" when it is done. Obviously, if you happen to pass it the string "doen" as input, it will return "done" although it isn't done... Try to avoid that!
Function nextPerm(s As String)
' inspired by https://stackoverflow.com/questions/352203/generating-permutations-lazily
' this produces the "next" permutation
' it allows one to step through all possible iterations without having to have them
' all in memory at the same time
Dim L As Integer, ii As Integer, jj As Integer
Dim c() As Byte, temp As Byte
L = Len(s)
If StrComp(s, "**done**") = 0 Or StrComp(s, "") = 0 Then
nextPerm = ""
Exit Function
End If
' convert to byte array... more compact to manipulate
ReDim c(1 To L)
For ii = 1 To L
c(ii) = Asc(Mid(s, ii, 1))
Next ii
' find the largest "tail":
For ii = L - 1 To 1 Step -1
If c(ii) < c(ii + 1) Then Exit For
Next ii
' if we complete the loop without break, ii will be zero
If ii = 0 Then
nextPerm = "**done**"
Exit Function
End If
' find the smallest value in the tail that is larger than c(ii)
' take advantage of the fact that tail is sorted in reverse order
For jj = L To ii + 1 Step -1
If c(jj) > c(ii) Then
' swap elements
temp = c(jj)
c(jj) = c(ii)
c(ii) = temp
Exit For
End If
Next jj
' now reverse the characters from ii+1 to the end:
nextPerm = ""
For jj = 1 To ii
nextPerm = nextPerm & Chr(c(jj))
Next jj
For jj = L To ii + 1 Step -1
nextPerm = nextPerm & Chr(c(jj))
Next jj
End Function
You can test it simply by adding it to a VBA module in your spreadsheet, and saving the workbook with .xlsm extension. Then you can type =nextPerm("abcd") in cell A1, and it should give you the next permutation - "abdc". Typing =nextPerm(A1) in A2 will compute the one after that, etc. You could copy all the way down the spreadsheet, and get every value.
If you copy the cells to a range that goes beyond the last permutation, it will return "**done**" as value for the first time this happens; and when you feed it "**done**" as input, it will return blank. This makes it obvious where things stop.
Take a look at this function -- it will list all possible permutations of a set of numbers using recursion.
http://www.vb-helper.com/howto_permute.html
It's for VB6 but it should be basically working in the Excel's implementation of VBA too.
Anyway, I know I shouldn't be responding to other comments here in the answer, I'm really sorry. It's just that the author Simone S said "If anyone is interested in using the resulting function just ask me", however, there's no way to contact the person other than this. Simone, please, I've been looking for a Shapley-Shubik algorithm for hours. Could you please point me to the description of how to compute the index or the resulting function?
I don't understand why for each loop in vba doesn't return the good number of element when i use dynamic array.
For exemple, my array size is 4, and i have 5 iteration in for each loop ...
Public Sub test()
Dim t_direction() As String
Dim t_nextDirection() As String
Dim myDirection As Variant
Dim test As Integer
Var = 0
ReDim t_direction(4)
t_direction(0) = "N"
t_direction(1) = "S"
t_direction(2) = "E"
t_direction(3) = "W"
t_nextDirection = randomizeArray(t_direction)
For Each myDirection In t_nextDirection
Var = Var + 1
Next myDirection
MsgBox (UBound(t_nextDirection))
MsgBox (Var)
End Sub
Public Function randomizeArray(ByVal t_array As Variant) As String()
Dim i As Integer
Dim j As Integer
Dim tmp As String
Dim numItems As Integer
numItems = UBound(t_array) - 1
' Randomize the array.
For i = 0 To numItems
' Pick a random entry.
j = Rand(0, numItems)
' Swap the numbers.
tmp = t_array(i)
t_array(i) = t_array(j)
t_array(j) = tmp
Next i
'MsgBox (UBound(t_array))
randomizeArray = t_array
End Function
Public Function Rand(ByVal Low As Long, _
ByVal High As Long) As Integer
Rand = Int((High - Low + 1) * Rnd) + Low
End Function
At the moment you are creating a 5 element array with
ReDim t_direction(4)
as the first element occurs as t_direction(0)
You should either
create a 4 element array ReDim t_direction(3) (ie 0 to 3) and then use numItems consistent with that, or
create a 4 element array ReDim t_direction with a base of 1 (ie 1 to 4) and then use numItems consistent with that (ie numItems = UBound(t_array)). The Option Base 1 below forces the first element to be 1 (which is then ensured anyow by using ReDim t_direction(1 To 4)
The code below uses the later approach. It returns 4 and 4 rather than your current 4 and 5
Option Base 1
Public Sub test()
Dim t_direction() As String
Dim t_nextDirection() As String
Dim myDirection As Variant
Dim test As Integer
Var = 0
ReDim t_direction(1 To 4)
t_direction(1) = "N"
t_direction(2) = "S"
t_direction(3) = "E"
t_direction(4) = "W"
t_nextDirection = randomizeArray(t_direction)
For Each myDirection In t_nextDirection
Var = Var + 1
Next myDirection
MsgBox (UBound(t_nextDirection))
MsgBox (Var)
End Sub
Public Function randomizeArray(ByVal t_array As Variant) As String()
Dim i As Integer
Dim j As Integer
Dim tmp As String
Dim numItems As Integer
numItems = UBound(t_array)
' Randomize the array.
For i = 1 To numItems
' Pick a random entry.
j = Rand(1, numItems)
' Swap the numbers.
tmp = t_array(i)
t_array(i) = t_array(j)
t_array(j) = tmp
Next i
'MsgBox (UBound(t_array))
randomizeArray = t_array
End Function
Public Function Rand(ByVal Low As Long, _
ByVal High As Long) As Integer
Rand = Int((High - Low + 1) * Rnd) + Low
End Function
ReDim t_direction(4) actually declares t_direction as 0 To 4
Its better to be explicit:
ReDim t_direction(0 To 3)
In the absence of a specified lower bound (using the To clause), then the default lower bound is used.
This default can be set to 0 or 1 by using Option Base {0|1} at module level.
In the absence of Option Base then the default default is 0
Notes:
In VBA you are not limited to 0 or 1 as the lower bound, you can use any value you want.
To iterate over an array use
For i = LBound(arr) To UBound(arr)
To calculate the number of items in an array use
numItems = UBound(arr) - LBound(arr) + 1
This way you are not making any assumptions on what the lower bound is
I have an array prLst that is a list of integers. The integers are not sorted, because their position in the array represents a particular column on a spreadsheet. I want to know how I find a particular integer in the array, and return its index.
There does not seem to be any resource on showing me how without turning the array into a range on the worksheet. This seems a bit complicated. Is this just not possible with VBA?
Dim pos, arr, val
arr=Array(1,2,4,5)
val = 4
pos=Application.Match(val, arr, False)
if not iserror(pos) then
Msgbox val & " is at position " & pos
else
Msgbox val & " not found!"
end if
Updated to show using Match (with .Index) to find a value in a dimension of a two-dimensional array:
Dim arr(1 To 10, 1 To 2)
Dim x
For x = 1 To 10
arr(x, 1) = x
arr(x, 2) = 11 - x
Next x
Debug.Print Application.Match(3, Application.Index(arr, 0, 1), 0)
Debug.Print Application.Match(3, Application.Index(arr, 0, 2), 0)
EDIT: it's worth illustrating here what #ARich pointed out in the comments - that using Index() to slice an array has horrible performance if you're doing it in a loop.
In testing (code below) the Index() approach is almost 2000-fold slower than using a nested loop.
Sub PerfTest()
Const VAL_TO_FIND As String = "R1800:C8"
Dim a(1 To 2000, 1 To 10)
Dim r As Long, c As Long, t
For r = 1 To 2000
For c = 1 To 10
a(r, c) = "R" & r & ":C" & c
Next c
Next r
t = Timer
Debug.Print FindLoop(a, VAL_TO_FIND), Timer - t
' >> 0.00781 sec
t = Timer
Debug.Print FindIndex(a, VAL_TO_FIND), Timer - t
' >> 14.18 sec
End Sub
Function FindLoop(arr, val) As Boolean
Dim r As Long, c As Long
For r = 1 To UBound(arr, 1)
For c = 1 To UBound(arr, 2)
If arr(r, c) = val Then
FindLoop = True
Exit Function
End If
Next c
Next r
End Function
Function FindIndex(arr, val)
Dim r As Long
For r = 1 To UBound(arr, 1)
If Not IsError(Application.Match(val, Application.Index(arr, r, 0), 0)) Then
FindIndex = True
Exit Function
End If
Next r
End Function
array of variants:
Public Function GetIndex(ByRef iaList() As Variant, ByVal value As Variant) As Long
Dim i As Long
For i = LBound(iaList) To UBound(iaList)
If value = iaList(i) Then
GetIndex = i
Exit For
End If
Next i
End Function
a fastest version for integers (as pref tested below)
Public Function GetIndex(ByRef iaList() As Integer, ByVal value As Integer) As Integer
Dim i As Integer
For i = LBound(iaList) To UBound(iaList)
If iaList(i) = value Then: GetIndex = i: Exit For:
Next i
End Function
' a snippet, replace myList and myValue to your varible names: (also have not tested)
a snippet, lets test the assumption the passing by reference as argument means something. (the answer is no) to use it replace myList and myValue to your variable names:
Dim found As Integer, foundi As Integer ' put only once
found = -1
For foundi = LBound(myList) To UBound(myList):
If myList(foundi) = myValue Then
found = foundi: Exit For
End If
Next
result = found
to prove the point I have made some benchmarks
here are the results:
---------------------------
Milliseconds
---------------------------
result0: 5 ' just empty loop
result1: 2702 ' function variant array
result2: 1498 ' function integer array
result3: 2511 ' snippet variant array
result4: 1508 ' snippet integer array
result5: 58493 ' excel function Application.Match on variant array
result6: 136128 ' excel function Application.Match on integer array
---------------------------
OK
---------------------------
a module:
Public Declare Function GetTickCount Lib "kernel32.dll" () As Long
#If VBA7 Then
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems
#Else
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems
#End If
Public Function GetIndex1(ByRef iaList() As Variant, ByVal value As Variant) As Long
Dim i As Long
For i = LBound(iaList) To UBound(iaList)
If value = iaList(i) Then
GetIndex = i
Exit For
End If
Next i
End Function
'maybe a faster variant for integers
Public Function GetIndex2(ByRef iaList() As Integer, ByVal value As Integer) As Integer
Dim i As Integer
For i = LBound(iaList) To UBound(iaList)
If iaList(i) = value Then: GetIndex = i: Exit For:
Next i
End Function
' a snippet, replace myList and myValue to your varible names: (also have not tested)
Public Sub test1()
Dim i As Integer
For i = LBound(iaList) To UBound(iaList)
If iaList(i) = value Then: GetIndex = i: Exit For:
Next i
End Sub
Sub testTimer()
Dim myList(500) As Variant, myValue As Variant
Dim myList2(500) As Integer, myValue2 As Integer
Dim n
For n = 1 To 500
myList(n) = n
Next
For n = 1 To 500
myList2(n) = n
Next
myValue = 100
myValue2 = 100
Dim oPM
Set oPM = New PerformanceMonitor
Dim result0 As Long
Dim result1 As Long
Dim result2 As Long
Dim result3 As Long
Dim result4 As Long
Dim result5 As Long
Dim result6 As Long
Dim t As Long
Dim a As Long
a = 0
Dim i
't = GetTickCount
oPM.StartCounter
For i = 1 To 1000000
Next
result0 = oPM.TimeElapsed() ' GetTickCount - t
a = 0
't = GetTickCount
oPM.StartCounter
For i = 1 To 1000000
a = GetIndex1(myList, myValue)
Next
result1 = oPM.TimeElapsed()
'result1 = GetTickCount - t
a = 0
't = GetTickCount
oPM.StartCounter
For i = 1 To 1000000
a = GetIndex2(myList2, myValue2)
Next
result2 = oPM.TimeElapsed()
'result2 = GetTickCount - t
a = 0
't = GetTickCount
oPM.StartCounter
Dim found As Integer, foundi As Integer ' put only once
For i = 1 To 1000000
found = -1
For foundi = LBound(myList) To UBound(myList):
If myList(foundi) = myValue Then
found = foundi: Exit For
End If
Next
a = found
Next
result3 = oPM.TimeElapsed()
'result3 = GetTickCount - t
a = 0
't = GetTickCount
oPM.StartCounter
For i = 1 To 1000000
found = -1
For foundi = LBound(myList2) To UBound(myList2):
If myList2(foundi) = myValue2 Then
found = foundi: Exit For
End If
Next
a = found
Next
result4 = oPM.TimeElapsed()
'result4 = GetTickCount - t
a = 0
't = GetTickCount
oPM.StartCounter
For i = 1 To 1000000
a = pos = Application.Match(myValue, myList, False)
Next
result5 = oPM.TimeElapsed()
'result5 = GetTickCount - t
a = 0
't = GetTickCount
oPM.StartCounter
For i = 1 To 1000000
a = pos = Application.Match(myValue2, myList2, False)
Next
result6 = oPM.TimeElapsed()
'result6 = GetTickCount - t
MsgBox "result0: " & result0 & vbCrLf & "result1: " & result1 & vbCrLf & "result2: " & result2 & vbCrLf & "result3: " & result3 & vbCrLf & "result4: " & result4 & vbCrLf & "result5: " & result5 & vbCrLf & "result6: " & result6, , "Milliseconds"
End Sub
a class named PerformanceMonitor
Option Explicit
Private Type LARGE_INTEGER
lowpart As Long
highpart As Long
End Type
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As LARGE_INTEGER) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LARGE_INTEGER) As Long
Private m_CounterStart As LARGE_INTEGER
Private m_CounterEnd As LARGE_INTEGER
Private m_crFrequency As Double
Private Const TWO_32 = 4294967296# ' = 256# * 256# * 256# * 256#
Private Function LI2Double(LI As LARGE_INTEGER) As Double
Dim Low As Double
Low = LI.lowpart
If Low < 0 Then
Low = Low + TWO_32
End If
LI2Double = LI.highpart * TWO_32 + Low
End Function
Private Sub Class_Initialize()
Dim PerfFrequency As LARGE_INTEGER
QueryPerformanceFrequency PerfFrequency
m_crFrequency = LI2Double(PerfFrequency)
End Sub
Public Sub StartCounter()
QueryPerformanceCounter m_CounterStart
End Sub
Property Get TimeElapsed() As Double
Dim crStart As Double
Dim crStop As Double
QueryPerformanceCounter m_CounterEnd
crStart = LI2Double(m_CounterStart)
crStop = LI2Double(m_CounterEnd)
TimeElapsed = 1000# * (crStop - crStart) / m_crFrequency
End Property
Here's another way:
Option Explicit
' Just a little test stub.
Sub Tester()
Dim pList(500) As Integer
Dim i As Integer
For i = 0 To UBound(pList)
pList(i) = 500 - i
Next i
MsgBox "Value 18 is at array position " & FindInArray(pList, 18) & "."
MsgBox "Value 217 is at array position " & FindInArray(pList, 217) & "."
MsgBox "Value 1001 is at array position " & FindInArray(pList, 1001) & "."
End Sub
Function FindInArray(pList() As Integer, value As Integer)
Dim i As Integer
Dim FoundValueLocation As Integer
FoundValueLocation = -1
For i = 0 To UBound(pList)
If pList(i) = value Then
FoundValueLocation = i
Exit For
End If
Next i
FindInArray = FoundValueLocation
End Function
Is this what you are looking for?
public function GetIndex(byref iaList() as integer, byval iInteger as integer) as integer
dim i as integer
for i=lbound(ialist) to ubound(ialist)
if iInteger=ialist(i) then
GetIndex=i
exit for
end if
next i
end function
Taking care of whether the array starts at zero or one.
Also, when position 0 or 1 is returned by the function, making sure that the same is not confused as True or False returned by the function.
Function array_return_index(arr As Variant, val As Variant, Optional array_start_at_zero As Boolean = True) As Variant
Dim pos
pos = Application.Match(val, arr, False)
If Not IsError(pos) Then
If array_start_at_zero = True Then
pos = pos - 1
'initializing array at 0
End If
array_return_index = pos
Else
array_return_index = False
End If
End Function
Sub array_return_index_test()
Dim pos, arr, val
arr = Array(1, 2, 4, 5)
val = 1
'When array starts at zero
pos = array_return_index(arr, val)
If IsNumeric(pos) Then
MsgBox "Array starting at 0; Value found at : " & pos
Else
MsgBox "Not found"
End If
'When array starts at one
pos = array_return_index(arr, val, False)
If IsNumeric(pos) Then
MsgBox "Array starting at 1; Value found at : " & pos
Else
MsgBox "Not found"
End If
End Sub
'To return the position of an element within any-dimension array
'Returns 0 if the element is not in the array, and -1 if there is an error
Public Function posInArray(ByVal itemSearched As Variant, ByVal aArray As Variant) As Long
Dim pos As Long, item As Variant
posInArray = -1
If IsArray(aArray) Then
If not IsEmpty(aArray) Then
pos = 1
For Each item In aArray
If itemSearched = item Then
posInArray = pos
Exit Function
End If
pos = pos + 1
Next item
posInArray = 0
End If
End If
End Function
The only (& even though cumbersome but yet expedient / relatively quick) way I can do this, is to concatenate the any-dimensional array, and reduce it to 1 dimension, with "/[column number]//\|" as the delimiter.
& use a single-cell result multiple lookupall macro function on the this 1-d column.
& then index match to pull out the positions. (usuing multiple find match)
That way you get all matching occurrences of the element/string your looking for, in the original any-dimension array, and their positions. In one cell.
Wish I could write a macro / function for this entire process. It would save me more fuss.