I am running into a problem, Although very simple but stuck up, I have a string from a cell, I split the string into characters using Mid function and store it into an array. Now I want to print the array to a different range but I am unable to do it. I've tried many different codes but all in vein.
please help.
My Code is as
Option Base 1
Function Takseer(Rg As Variant)
Dim NewArray() As Variant
Dim StrEx As String
Dim k, l, m As Integer
StrEx = Rg
StrEx = WorksheetFunction.Substitute(StrEx, " ", "")
m = Len(StrEx)
For k = 1 To m
ReDim Preserve NewArray(1 To m)
NewArray(k) = Mid(StrEx, k, 1)
Next k
Range("C1:C12") = NewArray
End Function
You have to transpose the array to put values in a column.
Option Explicit
Option Base 1
Sub test()
Call Takseer("ABCDEFGHUIJKL")
End Sub
Function Takseer(StrEx As String)
Dim NewArray() As Variant, s As String, m As Integer, k As Integer
s = Replace(StrEx, " ", "")
m = Len(s)
If m = 0 Then Exit Function
ReDim NewArray(m)
For k = 1 To m
NewArray(k) = Mid(s, k, 1)
Next k
' in a row
Sheet1.Range("C1").Resize(1, m) = NewArray
' in a column
Sheet1.Range("C2").Resize(m, 1) = WorksheetFunction.Transpose(NewArray)
End Function
Assuming the array you obtain is "Apple", "Orange", "Grape", "Durian", in order to write into worksheet you cannot directly call the variant. One way to write the value is to first get the length of your variant, then write the value from array starting from index 0, here is how I perform you expectation:
Sub test1()
Dim NewArray() As Variant
Dim i As Long, arrayLoop As Long
Dim StrEx As String
Dim k, l, m As Integer
StrEx = "Hello today is my first day"
StrEx = WorksheetFunction.Substitute(StrEx, " ", "")
m = Len(StrEx)
For k = 0 To m - 1
ReDim Preserve NewArray(m - 1)
NewArray(k) = Mid(StrEx, k + 1, 1)
Next k
i = UBound(NewArray) - LBound(NewArray) + 1
For arrayLoop = 0 To i - 1
Sheet1.Range("A" & arrayLoop + 1).Value = NewArray(arrayLoop)
Next
End Sub
Please take note when perform array loop, you have to minus the length by 1, else it will be out of range, the reason is that array index always start from zero based (0)
And check the post for how to obtain length of array Get length of array?
Some problems with your function:
A formula returns a value. It is not used to alter other properties/cells of a worksheet.
Hence you should set your results to the function; not try to write to a range
Dim k, l, m As Integer only declares m as Integer, k and l are unspecified so they will be declared as a variant.
The constructed array will be horizontal. If you want the results vertical, you need to Transpose it, or create a 2D array initially.
Option Base 1 is unnecessary since you explicitly declare the lower bound
Assuming you want to use this function on a worksheet, TestIt sets things up.
Note2: The formula on the worksheet assumes you have Excel with dynamic arrays. If you have an earlier version of Excel, you will need to have a different worksheet formula
See your modifed function and TestIt:
Modified with Transpose added to worksheet formula
Option Explicit
Function Takseer(Rg As Variant)
Dim NewArray() As Variant
Dim StrEx As String
Dim k As Long, l As Long, m As Long
StrEx = Rg
StrEx = WorksheetFunction.Substitute(StrEx, " ", "")
m = Len(StrEx)
For k = 1 To m
ReDim Preserve NewArray(1 To m)
NewArray(k) = Mid(StrEx, k, 1)
Next k
Takseer = NewArray
End Function
Sub TestIt()
[a1] = "abcdefg"
[c1].EntireColumn.Clear
[c1].Formula2 = "=Transpose(Takseer(A1))"
End Sub
Modified to create 2d vertical array
can't really use redim preserve on this array. And I prefer to avoid it anyway because of the overhead
Option Explicit
Function Takseer(Rg As Variant)
Dim NewArray() As Variant, col As Collection
Dim StrEx As String
Dim k As Long, l As Long, m As Long
StrEx = Rg
StrEx = WorksheetFunction.Substitute(StrEx, " ", "")
m = Len(StrEx)
Set col = New Collection
For k = 1 To m
col.Add Mid(StrEx, k, 1)
Next k
ReDim NewArray(1 To col.Count, 1 To 1)
For k = 1 To col.Count
NewArray(k, 1) = col(k)
Next k
Takseer = NewArray
End Function
Sub TestIt()
[a1] = "abcdefg"
[c1].EntireColumn.Clear
[c1].Formula2 = "=Takseer(A1)"
End Sub
Note:
TestIt is merely to test the function. You should enter the appropriate formula yourself, either manually or programmatically, into the destination range.
If you do not have dynamic arrays, then you would need to enter an array formula into the destination range; or a formula using the INDEX function to return each element of the array.
In TestIt, you might change the line that puts the formula onto the worksheet to Range(Cells(1, 3), Cells(Len([a1]), 3)).FormulaArray = "=Takseer(a1)", but, again, it is anticipated that you would be entering the correct formula onto your worksheet manually or programmatically anyway.
Related
I have 2 arrays that I want to combine into a single array of all possible combinations. I then need to loop through all of the combinations and popular arguments for a function. My arrays are not equal in size, and my attempts so far have resulted in a combined array only having 1 pair of values. This is VBA in PowerPoint, not Excel, if that makes a difference to available syntax.
How can I go from this:
arrayColor = Array("Blue","Green","Red")
arraySize = Array("XS","S","M","L","XL")
To this:
arrayCombo(0,0) = "Blue"
arrayCombo(0,1) = "XS"
arrayCombo(1,0) = "Blue"
arrayCombo(1,1) = "S"
...
arrayCombo(15,0) = "Red"
arrayCombo(15,1) = "XL"
And then use a loop to call each pair of values and populate argument values. This code just to illustrate the concept; it's certainly not legit. Pretty sure I need a nested loop here?
For i = 0 To UBound(arrayCombo(i))
nextSubToFire(color, size)
Next i
This is what I've got so far, but it only results in a single pair in my combined array. It's based on this question, but I think I'm either missing something or the sole answer there isn't quite correct. I've looked at other similar questions, but can't wrap my head around doing this with an array compiled in the code rather than the other examples all tailored to Excel.
Option Explicit
Dim arrayColorSize, arrayCombo
Sub CoreRoutine()
Dim arrayColor, arraySize
arrayColor = Array("Blue","Green","Red")
arraySize = Array("XS","S","M","L","XL")
arrayColorSize = Array(arrayColor, arraySize)
arrayCombo = Array(0, 0)
DoCombinations (0)
Dim a As Integer
Dim b As Integer
'For loop comes next once I figure out how to populate the full arrayCombo
End Sub
Sub DoCombinations(ia)
Dim i
For i = 0 To UBound(arrayColorSize(ia)) ' for each item
arrayCombo(ia) = arrayColorSize(ia)(i) ' add this item
If ia = UBound(arrayColorSize) Then
Else
DoCombinations (ia + 1)
End If
Next i
End Sub
Using the Locals window, I see arrayCombo exists, but it only has 1 pair of values in it, which is the last set of pairing options. I see that arrayColorSize has the 2 array sets as I'd expect, so I suspect the DoCombinations sub is missing something.
Any guidance much appreciated!
One way of doing this is to combine the two 1D arrays into a 2D array with 2 columns (as in your example):
Private Function Combine1DArrays(ByRef arr1 As Variant, ByRef arr2 As Variant) As Variant
If GetArrayDimsCount(arr1) <> 1 Or GetArrayDimsCount(arr2) <> 1 Then
Err.Raise 5, "Combine1DArrays", "Expected 1D arrays"
End If
'
Dim count1 As Long: count1 = UBound(arr1) - LBound(arr1) + 1
Dim count2 As Long: count2 = UBound(arr2) - LBound(arr2) + 1
Dim i As Long, j As Long, r As Long
Dim result() As Variant
'
ReDim result(0 To count1 * count2 - 1, 0 To 1)
r = 0
For i = LBound(arr1) To UBound(arr1)
For j = LBound(arr2) To UBound(arr2)
result(r, 0) = arr1(i)
result(r, 1) = arr2(j)
r = r + 1
Next j
Next i
Combine1DArrays = result
End Function
Public Function GetArrayDimsCount(ByRef arr As Variant) As Long
Const MAX_DIMENSION As Long = 60
Dim dimension As Long
Dim tempBound As Long
'
On Error GoTo FinalDimension
For dimension = 1 To MAX_DIMENSION
tempBound = LBound(arr, dimension)
Next dimension
FinalDimension:
GetArrayDimsCount = dimension - 1
End Function
You can use it like this for example:
Sub CoreRoutine()
Dim arrayColorSize As Variant
Dim i As Long
Dim color As String
Dim size As String
'
arrayColorSize = Combine1DArrays(Array("Blue", "Green", "Red") _
, Array("XS", "S", "M", "L", "XL"))
For i = LBound(arrayColorSize, 1) To UBound(arrayColorSize, 1)
color = arrayColorSize(i, 0)
size = arrayColorSize(i, 1)
NextSubToFire color, size
Next i
End Sub
Sub NextSubToFire(ByVal color As String, ByVal size As String)
Debug.Print color, size
End Sub
Below is some code I wrote to handle arrays and ranges uniformly (Accepting a range as an array parameter). It contains a function called sanitise which is meant to be a function you can call on some 2D collection of numbers A, and get the same numbers back as a 2D array of Doubles.
Public Function item(ByRef A As Variant, i As Integer, j As Integer) As Double
If TypeName(A) = "Range" Then
item = A.Cells(i, j)
Else
item = A(i, j)
End If
End Function
Public Function rows(ByRef A As Variant) As Integer
If TypeName(A) = "Range" Then
rows = A.rows.Count
Else
rows = UBound(A, 1) - LBound(A, 1) + 1
End If
End Function
Public Function cols(ByRef A As Variant) As Integer
If TypeName(A) = "Range" Then
cols = A.columns.Count
Else
cols = UBound(A, 2) - LBound(A, 2) + 1
End If
End Function
Public Function sanitise(ByRef A As Variant) As Double()
Debug.Print TypeName(A)
If TypeName(A) = "Double()" Then
sanitise = A
Else
Debug.Print rows(A)
Dim B() As Double
ReDim B(1 To rows(A), 1 To cols(A))
Dim i As Integer, j As Integer
For i = 1 To rows(A)
For j = 1 To cols(A)
B(i, j) = item(A, i, j)
Next j
Next i
sanitise = B
End If
End Function
The implementation works exactly as you'd expect it: select a range in the worksheet, say A1:B2, call sanitize on it and you'll have two copies of the same thing:
What goes wrong however, is sanitise^2.
Calling sanitise twice breaks down, but only if you call it on single row. Multiple rows: fine, single column: fine.
I know why it happens: after the first sanitise, Excel forgets what shape array was returned. (It also forgets the type: instead of Double() the input to the second sanitise is Variant())
Does anybody know how to work around this issue?
While it's unlikely that I'd ever want to use sanitise twice in a row, the above example illustrates why it's difficult to compose two functions along a 2 dimensional array.
Note: this is issue only happens when sanitise is called from a worksheet.
Update, I've figured it out: for the worksheets 1D storage in synonymous with row, so that needs to be taken into consideration
My final version:
Public Function get_2D(ByRef A As Variant) As Double()
'turns various forms of input into a 2D array of Doubles
Dim result() As Double
Dim i As Integer
If TypeOf A Is Range Or dims(A) = 2 Then
ReDim result(1 To rows(A), 1 To cols(A))
Dim j As Integer
For i = 1 To rows(A)
For j = 1 To cols(A)
result(i, j) = item(A, i, j)
Next j
Next i
Else
'1D storage is treated as a row
ReDim result(1 To 1, 1 To rows(A)) 'rows(A) gets length of the first axis
For i = 1 To rows(A)
result(1, i) = A(i)
Next i
End If
sanitise = result
End Function
dims is a function that returns the number of dimensions of an array: https://support.microsoft.com/en-us/kb/152288
I think this is somewhat aligned with your specification and it has the benefit of solving the single row problem you demonstrate. Would it work for your purposes?
Function sanitise_sugg(inp As Variant) As Variant
Dim result As Variant
If TypeOf inp Is Object Then
result = inp.Value
Else
result = inp
End If
sanitise_sugg = result
End Function
Edit: Taking one step back I think you should divide the task at hand into two: First use "sanitise_sugg" to use excel ranges and excel-vba arrays interchangeabely. Then if you for a special need demand the input to specifcally be some sort of Array of doubles, write a separate function that tests and if possible casts a variant input to this type.
Edit 2: Taking one step forward instead, let me claim that in the case the elements fed to Function sanitise_sugg(inp As Variant) As Variant contain doubles from within vba, or cells with numeric values from an excel sheet, it meets the specifciation demanded for Public Function sanitise(ByRef A As Variant) As Double()
Edit 3: To see how the function keeps track of its input Array layout independently of beeing Row vector, Column vector or full Matrix, independently of beeing passed the Array from an excel range or from within VBA, please refer to the below worksheet;
I can't think of any practical use for this unless you do a lot of calculations on the 2D array of Doubles, so if you give more information on what exactly you are trying to do, we can probably recommend something easier/better/more efficient etc.
.Value and .Value2 return 2D Variant array when more than one cell in the range:
v = [a1:b1].Value2 ' Variant/Variant(1 to 1, 1 to 2)
v = [a1:a2].Value2 ' Variant/Variant(1 to 2, 1 to 1)
v = [a1].Value2 ' Variant/Double
so a naive approach can be something like:
Function to2D(v) As Double()
'Debug.Print TypeName(v), VarType(v)
Dim d2() As Double, r As Long, c As Long
If IsArray(v) Then
If TypeOf v Is Range Then v = v.Value2
ReDim d2(1 To UBound(v, 1), 1 To UBound(v, 2))
For r = 1 To UBound(v, 1)
For c = 1 To UBound(v, 2)
If IsNumeric(v(r, c)) Then d2(r, c) = v(r, c)
Next c
Next r
Else
ReDim d2(1 To 1, 1 To 1)
If IsNumeric(v) Then d2(1, 1) = v
End If
to2D = d2
End Function
and tested with:
d2 = to2D([a1:b2])
d2 = to2D([a1:b1])
d2 = to2D([a1:a2])
d2 = to2D([a1])
d2 = to2D(1)
d2 = to2D([{" 1 ";" 2.0 "}]) ' works with strings too
d2 = to2D([{1,2;3,4}])
'd2 = to2D([{1,2}]) ' doesn't work with 1D arrays
I need a function to extract 2 dimensions from a multidimesion array. which 2 dimensions to extract depending on the choise of the user. and the index in the discarded dimensions where those 2 dimensions are picked also depending on the user.
For example, i have a 3 dimension array v(1 to 100, 1 to 20, 1 to 10). i would like to extrat dimension 1 and dimension 3 from v. and the index in the discared dimension 2 is 11.
sub extract
dim i1 as integer 'for loop through dimension 1
dim i2 as integer 'for loop through dimension 3
dim d1 as integer 'index in dimension 2
d1=11
redim vn(1 to ubound(v,1),1 to ubound (v,3))
for i1 = 1 to ubound(v,1)
for i2= 1 to ubound(v,3)
vn(i1,i2)=v(i1,d1,i2)
next i2
next i1
end sub
I can extract dimensions from array, if i know which dimensions i need and the index (d1) in the discarded dimensions. however, i need to leave that to the users to decide. what i want is a function like that:
function extract(i1 as integer, i2 as intger, paramarray ov()) as variant
=extract(the_first_dimension_to_keep,the_second_dimension_to_keep,[index_in_the_first_discard_dimension,index_in_the_second_discard_dimension,...])
Keeping in mind that the origional array can have more than 3 dimensions, so list all the possibility in the code is not possible.
Any solution?
The quickest way would be to read the array with a pointer and increment the pointer value by an algorithmic value based on the number of dimensions and number of elements in each. This site has an excellent tutorial on managing pointers to arrays: http://bytecomb.com/vba-internals-getting-pointers. However, it'd be one mighty coding task - just dimensioning the rgabounds of your SAFEARRAY for the memory read would be a task - and if your array values were Strings, it'd be of an order of magnitude mightier.
An easier, though doubtless slower, option would be to exploit the For Each looping method, which can be applied to an array. Its looping sequence is like so:
arr(1,1)
arr(2,1)
arr(3,1)
arr(1,2)
arr(2,2)
arr(3,2)
etc.
So you'd only need a simple odometer-style index counter.
You could basically iterate every element in the array and if the combination of indexes matched what you wanted, you'd read the element into your extraction array. That would be a much easier task. The code below shows you how you could do this on a multi-dimensional array of unknown dimensions.
Option Explicit
Private Type ArrayBounds
Lower As Long
Upper As Long
Index As Long
WantedDimension As Boolean
DiscardIndex As Long
End Type
Public Sub RunMe()
Dim arr As Variant
Dim result As Variant
arr = CreateDummyArray
result = Extract(arr, 1, 3, 11)
End Sub
Private Function Extract(arr As Variant, i1 As Integer, i2 As Integer, ParamArray ov() As Variant) As Variant
Dim d As Long
Dim bounds() As ArrayBounds
Dim i As Long
Dim v As Variant
Dim ovIndex As Long
Dim doExtract As Boolean
Dim result() As Variant
'Dimension the output array
ReDim result(LBound(arr, i1) To UBound(arr, i1), LBound(arr, i2) To UBound(arr, i2))
'Get no. of dimensions in array
d = GetDimension(arr)
'Now we know the number of dimensions,
'we can check that the passed parameters are correct
If (i1 < 1 Or i1 > d) Or (i2 < 1 Or i2 > d) Then
MsgBox "i1/i2 - out of range"
Exit Function
End If
If UBound(ov) - LBound(ov) + 1 <> d - 2 Then
MsgBox "ov - wrong number of args"
Exit Function
End If
'Resise and populate the bounds type array
ReDim bounds(1 To d)
ovIndex = LBound(ov)
For i = 1 To d
With bounds(i)
.Lower = LBound(arr, i)
.Upper = UBound(arr, i)
.Index = .Lower
.WantedDimension = (i = i1) Or (i = i2)
If Not .WantedDimension Then
.DiscardIndex = ov(ovIndex)
ovIndex = ovIndex + 1
'Check index is in range
If .DiscardIndex < .Lower Or .DiscardIndex > .Upper Then
MsgBox "ov - out of range"
Exit Function
End If
End If
End With
Next
'Iterate each member of the multi-dimensional array with a For Each
For Each v In arr
'Check if this combination of indexes is wanted for extract
doExtract = True
For i = 1 To d
With bounds(i)
If Not .WantedDimension And .Index <> .DiscardIndex Then
doExtract = False
Exit For
End If
End With
Next
'Write value into output array
If doExtract Then
result(bounds(i1).Index, bounds(i2).Index) = v
End If
'Increment the dimension index
For i = 1 To d
With bounds(i)
.Index = .Index + 1
If .Index > .Upper Then .Index = .Lower Else Exit For
End With
Next
Next
Extract = result
End Function
Private Function GetDimension(arr As Variant) As Long
'Helper function to obtain number of dimensions
Dim i As Long
Dim test As Long
On Error GoTo GotIt
For i = 1 To 60000
test = LBound(arr, i)
Next
Exit Function
GotIt:
GetDimension = i - 1
End Function
I have the following code:
Function SplitMe(sourceArray As Variant) As Variant
Dim source As Variant, tempArr As Variant
source = sourceArray
If Not IsArray(source) Then _
Exit Function
Dim r As Integer
Dim parts() As String
Dim splitted As Variant
ReDim splitted(LBound(source) To UBound(source))
For r = LBound(source) To UBound(source)
parts = VBA.Split(source(r, 1), "\")
splitted(r) = parts
Next r
It works fine until here:
splitted = Application.Transpose(splitted)
SplitMe = splitted
For r = LBound(splitted) To UBound(splitted)
Debug.Print uniqueValues(splitted, r)
Next r
End Function
At this Point I want to transpose the Array. It works fine if the Arrays within the splited Array are the same size. The Problem occurs when I have a query like this:
The transposing is necessary for the uniqueValues(splitted, r) function.
I now want to write a function that goes ahead and adds length to the queries that are not the maximal size.
In this case splitted(1) would give the length 0 to 9 and then the other 5 nodes would need to be increased to be 0 to 9.
Anyone with a function at hand that does that?
The following function resizes an Array of an Array to the same dimensions:
Function oneDimensionArray(tmpArr As Variant, maxDim As Long) As Variant
Dim r As Long, redimArray As Variant
For r = LBound(tmpArr) To UBound(tmpArr)
redimArray = tmpArr(r)
If maxDim > UBound(redimArray) Then ReDim Preserve redimArray(LBound(redimArray) To maxDim)
tmpArr(r) = redimArray
Next r
oneDimensionArray = tmpArr
End Function
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?