I have a two dimensional Array which is filled row by row. I got like ~200 entries. This is variable but also duplicates are filled.
How can i remove those duplicates? Or even check if the entries already exist in the Array and skip that duplicate entry?
for each oSingleNode in oNodeList
if oSingleNode.xml <> "" Then
Set oNode = oSingleNode.selectSingleNode("j.8:entity-reference")
if not oNode is nothing then
s = oNode.getAttribute("rdf:resource")
a = Split(s, "/")
attribute = a(ubound (a)-1)
Set oNodeTwo = oSingleNode.selectSingleNode("j.8:entity-label")
if not oNodeTwo is nothing then
label = oNodeTwo.text
array(rowIndex,index) = attribute
array(rowIndex,constClm)= label
debug2File array(rowIndex,index) & " " & array (rowIndex, constClm)
End if
End if
End If
The question was really interesting that's why a make a try on it.sorry for violating the tag since they ware requested for support in vb script, hope that this will make you think of my concept and make try the same in vb script, my result is as follows.
Dim a(10, 10), i, j As Integer
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
j += 1
If j > 10 Then
i += 1
j = 0
End If
check_val(CInt(TextBox1.Text), i, j)
End Sub
the function will check for duplicates and insert if not exist
Public Sub check_val(ByVal x As Integer, ByVal i As Integer, ByVal j As Integer)
Dim t As Integer = 0
For k As Integer = 0 To 10
For l As Integer = 0 To 10
If x = a(k, l) Then
t = 1
End If
Next
Next
If t = 0 Then
a(i, j) = x
Else
MsgBox("Repeting value")
j = j - 1
End If
End Sub
Related
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.
I have an array that is declared within a subroutine. I want it filled with two values. one for each coordinate of a list of cells. I know that this isn't always the best way to do this, but for reasons involving the rest of my program, I need to do it exactly this way.
'This sub contains more, I've just included only the relevant stuff
Sub Start_Click()
Dim arTime() As Integer
arTime = FillTimeArray(arTime)
End Sub
'This is used to fill the array with a list of 12 columns that are 24 rows long
'They are offsetted intentionally
Function FillSpotArray(ByRef arr() As Integer) As Integer()
For j = 0 To 11
For i = 0 To 23
arr(i, j) = Format(i + 2, j + 1)
Next i
Next j
End Function
You have not dimensioned your array:
Sub Start_Click()
Dim arTime(23, 11) As Integer
arTime = FillTimeArray(arTime)
End Sub
You need to Dim you array, call the function correctly, and return the output correctly in the function
Sub Start_Click()
Dim arTime As Variant
arTime = FillSpotArray()
End Sub
'This is used to fill the array with a list of 12 columns that are 24 rows long
'They are offsetted intentionally
Function FillSpotArray() As Integer()
Dim arr(23, 11) As Integer
For j = 0 To 11
For i = 0 To 23
arr(i, j) = Format(i + 2, j + 1)
Next i
Next j
FillSpotArray = arr
End Function
I'm not entirely sure of your use of Format here though
Hello im having trouble with my code !
we are asked to organize a list of names from a text.txt file the make them show up into a lits box (got that part down :) ) . then from the list box we are asked to create an array and sort that array (using our own sorting method) and organize the names using a button in assending order and another button organizing the array in decending order. the results from the orders names should appear in another list box .
i have gotten only the last name in the list to show up in the second list box but my code has no errors it just wont order the names properly! Help!!!!!
here is my code :)
Public Class FileSort
Dim sr As IO.StreamReader = IO.File.OpenText("C:\Users\Inspiron 15\documents\visual studio 2010\Projects\assigment4 EL\assigment4 EL\names.txt")
Structure names
Dim c As Integer
Dim fullname As String
End Structure
Dim allNames(99) As names
Private Sub btnName_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnName.Click
Do While sr.Peek <> -1
Name = sr.ReadLine
LstNames.Items.Add(Name & " ")
Loop
sr.Close()
End Sub
Private Sub bubbelsort(ByRef names() As System.String, ByVal c As Integer)
c = 0
names(c) = sr.ReadLine()
c = c * 1
For c = 1 To 99 Step +1 '~~~ Addding (Z to A) to the the Listbox
lstOrderedNames.Items.Add(Name & "")'
Next
End Sub
Private Sub BtnAssend_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles BtnAssend.Click
Dim names(99) As String
Dim c As Integer
c = 0
Dim A As Integer
A = 99
names(c) = sr.ToString
c = c + 1
For c = 1 To 99 Step +1 '~~~ Addding (Z to A) to the the Listbox
lstOrderedNames.Items.Add(Name & "")
Next
End Sub
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles BtnDessend.Click
Dim names(99) As String
Dim c As Integer
c = 0
Dim A As Integer
A = 99
names(c) = sr.ToString
names(A) = sr.ToString
A = A - 1
For A = 99 To 0 Step -1 '~~~ Addding (Z to A) to the the Listbox
lstOrderedNames.Items.Add(Name & "")
Next
End Sub
enter image description here
Since your problem is the sorting algorithm (if I understand this correctly).
At first we need an array.
Dim arr(ListBox1.Items.Count - 1) As String
For i As Integer = 0 To arr.Length - 1
arr(i) = CStr(ListBox1.Items(i))
Next
Next the sorting algorithm. Since you wanted to go with BubbleSort:
Private Sub StringBubbleSort(arr As String)
For i As Integer = 0 To arr.Length - 1
For j As Integer = 0 To arr.Length - 2 - i
If String.Compare(arr(j), arr(j + 1)) > 0 Then
Dim temp As String = arr(j)
arr(j) = arr(i)
arr(i) = temp
End If
Next
Next
End Sub
Then you use this function and copy the array to your second ListBox.
StringBubbleSort(arr)
ListBox2.Items.AddRange(arr)
String.Compare: https://msdn.microsoft.com/de-de/library/84787k22(v=vs.110).aspx
you could use linq
ListBox1.Items.Add("Battle")
ListBox1.Items.Add("Cattle")
ListBox1.Items.Add("apple")
ListBox2.DataSource = (From l In ListBox1.Items
Select l Order By l Ascending).ToList
This is a console application which generates a times table with user input by asking the user to input rows and columns. I get two big errors in this code:
Value of type '1-dimensional array of 1-dimensional array of Integer' cannot be converted to '1-dimensional array of Integer' 'because '1-dimensional array of Integer' is not derived from 'Integer'
and
'jaggedArrayArray' is not declared. It may be inaccessible due to its protection level.
After some research online, I have come across two big concepts - Deep Copy and Shallow Copy - which I am still learning. I think that my main problem has to do with Sub arrayPopulateJ:
Sub arrayPopulateJ(ByVal jaggedArray() As Integer, ByVal columns As Integer, ByVal rows As Integer)
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim mult(columns) As Integer
'Populates rows in jagged array
For i = 0 To rows
jaggedArray(i) = (i + 1)
Next
'Populates columns in arrays
For i = 0 To rows
For j = 0 To columns
For k = 0 To columns
mult(k) = (j + 1) * (k + 1)
Next
Next
jaggedArray(i) = mult(columns)
Next
End Sub
If you look at the line jaggedArray(i) = mult(columns) I think I am doing what is called a shallow copy and it is making this whole thing not work. What I want to happen is I want to be able to use jaggedArray as a 1D array and put 1D arrays into its elements (in my code that would be mult(columns)). I am still new to programming and VB and I am not sure how to do this. I thought that VB would be a high enough language that the flow of logic would work this way. But as I know now that is not the case. So what can I do to pass an whole array into a array and get this to work?
FULL CODE:
Module Module1
Sub Main()
'Declarations
Dim awns As Char
Dim switchOption As Integer
Dim columns As Integer
Dim rows As Integer
Dim regularArray(,) As Integer = New Integer(,) {}
Dim jaggedArray()() As Integer = New Integer(rows)() {} 'Problem here
Dim topArray(columns) As Integer
Dim sideArray(rows) As Integer
'Starting Prompts
Console.WriteLine("Hello this program will create a times table with")
Console.WriteLine("user inputs in terms of rows and columns.")
Console.WriteLine("Pick between these two options.")
Console.WriteLine("Option 1: Times table with a regular array.")
Console.WriteLine("Option 2: Times table with a jagged array.")
Do
Console.Write("Which option do you want? ")
switchOption = Console.ReadLine
Console.WriteLine("How many columns do you want? ")
columns = Console.ReadLine
columns = columns - 1
Console.WriteLine("How many rows do you want? ")
rows = Console.ReadLine
rows = rows - 1
Console.Write(vbNewLine)
'ReDim's
ReDim regularArray(columns, rows)
ReDim jaggedArray(rows)
ReDim topArray(columns)
ReDim sideArray(rows)
Select Case switchOption
Case 1
'Array populations
arrayPopulate(regularArray, columns, rows)
singlePopulate(topArray, columns)
singlePopulate(sideArray, rows)
Dim i As Integer
Dim j As Integer
Console.Write(" ")
For j = 0 To columns
Dim top As String = topArray(j)
Console.Write(top.PadLeft(3) + ": ")
Next
Console.Write(vbNewLine)
For j = 0 To rows
Dim side As String = sideArray(j)
Console.Write(side.PadLeft(3) + ": ")
For i = 0 To columns
Dim num As String = regularArray(i, j)
Console.Write(num.PadLeft(3) + ": ")
Next
Console.Write(vbNewLine)
Next
Case 2
'Array populations
arrayPopulateJ(jaggedArray, columns, rows) 'Problem here
singlePopulate(topArray, columns)
singlePopulate(sideArray, rows)
Dim i As Integer
Dim j As Integer
Console.Write(" ")
For j = 0 To columns
Dim top As String = topArray(j)
Console.Write(top.PadLeft(3) + ": ")
Next
Console.Write(vbNewLine)
For j = 0 To rows
Dim side As String = sideArray(j)
Console.Write(side.PadLeft(3) + ": ")
Dim num As String = jaggedArrayArray(j) 'Problem here
Console.Write(num.PadLeft(3))
Console.Write(vbNewLine)
Next
End Select
Console.WriteLine("Do you want to run again y/n?")
awns = Console.ReadLine()
Loop Until awns = "n"
End Sub
Sub arrayPopulateJ(ByVal jaggedArray() As Integer, ByVal columns As Integer, ByVal rows As Integer)
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim mult(columns) As Integer
ReDim mult(columns)
'Populates rows in jagged array
For i = 0 To rows
jaggedArray(i) = (i + 1)
Next
'Populates columns in arrays
For i = 0 To rows
For j = 0 To columns
For k = 0 To columns
mult(k) = (j + 1) * (k + 1)
Next
Next
jaggedArray(i) = mult(columns)
Next
End Sub
Sub arrayPopulate(ByVal regularArray(,) As Integer, ByVal columns As Integer, ByVal rows As Integer)
'Local Declarations
Dim i As Integer
Dim j As Integer
Dim mult As Integer
For i = 0 To rows
For j = 0 To columns
mult = (i + 1) * (j + 1)
regularArray(j, i) = mult
Next
Next
End Sub
Sub singlePopulate(ByVal topArray() As Integer, ByRef count As Integer)
'Local Declarations
Dim i As Integer
Dim pop As Integer
For i = 0 To count
pop = (i + 1)
topArray(i) = pop
Next
End Sub
End Module
There is no "deep" or "shallow" copy issue here. That's a red herring.
Your first problem was that you had jaggedArrayArray in your code, but the variable was declared as jaggedArray.
The next problem that arrayPopulateJ was expecting the first parameter to be of type Integer() when it should have been Integer()().
Fixing both of this it was then just an easy matter of writing arrayPopulateJ to be:
Sub arrayPopulateJ(ByVal jaggedArray()() As Integer, ByVal columns As Integer, ByVal rows As Integer)
For i = 0 To rows
Dim column(columns) As Integer
jaggedArray(i) = column
For j = 0 To columns
jaggedArray(i)(j) = (i + 1) * (j + 1)
Next
Next
End Sub
I also cleaned up arrayPopulate to be:
Sub arrayPopulate(ByVal regularArray(,) As Integer, ByVal columns As Integer, ByVal rows As Integer)
For i = 0 To rows
For j = 0 To columns
regularArray(j, i) = (i + 1) * (j + 1)
Next
Next
End Sub
I ran your code at that point and it worked.
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?