在VBA中排列一个数组来计算Shapley-Shubik幂指数

我想这是我在这个论坛上的第一个问题，所以如果我错过了一些规则，不好意思。 我正在尝试编写一个VBAalgorithm来计算Shapley-Shubik索引。 这个指数需要计算一系列数字（代表议会，国会等的选票）的所有排列。 经过一番深入的研究，我明白了一个人必须使用recursionalgorithm来执行这样的事情。

我的想法是在VBA中创build一个matrix，其中每个元素分开存储，每行包含不同的排列。 这是我可以随后执行计算并检索计算此类索引所需的正确标签值的唯一方法。 问题是我无法理解如何恢复到以前的水平，一旦我达到recursion的最后一级。

（编辑）最终，我能够想出一个解决scheme。 我发布了下面的结果，因为我已经看到它已被要求。 我应该警告，这是一个非常低效的代码，它不能和超过7个玩家一起工作。 这是因为vba不能处理由这个代码创build的非常大的matrix，所以程序只是崩溃而出现溢出错误。

然而，在编写这段代码时，这并不是特别聪明，这意味着修改代码以使其能够为更多的玩家工作是非常容易的。 基本上，不是使用排列函数来创buildmatrix，而是需要计算每个特定排列中的关键球员，然后使用数组“存储”频率。 不幸的是，我没有时间修改代码，因为我目前正在其他项目上工作，虽然有些相关，使用Matlab代替。

这是我组装的function：

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 (eg 0.5 for 50%)" Application.MacroOptions _ Macro:=FuncName, _ Description:=FuncDesc, _ Category:=Category, _ ArgumentDescriptions:=ArgDesc End Sub 

对不起，如果一些变数是意大利语。 另外，代码的某些部分已经在一些专门的论坛中被检索到了，所以我没有特别的指示，只是为了组装:)最后一个请求：如果有人能够改善这个代码，请分享它所以每个人都可以使用它。

Answer 1

我不会完全回答你的问题。 但是我想给你提供一个很好的小函数来帮助你解决更大的问题。 这个函数生成一个string的“下一个”排列 – string可以包含数字或字母，而“next”在词典意义上（参见[this discussion]（ 生成排列 ））。

你能用它做什么？ 那么，当你想计算任何“所有可能的排列组合”时，有一个函数会给你“只是下一个排列”，这会让你的代码可读（这会带走很多内务！）。 你可以简单地说（这是伪代码）：

 // 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 

这是function。 它似乎为我自己 – 即使我在string中有多个相同的字符，或字母和数字的混合物。 请注意，它将A和a视为不同的…还要注意，它在完成时返回string“done”。 显然，如果你碰巧把string"doen"作为input，它会返回“完成”，虽然它没有完成…尽量避免这样做！

  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 

您只需将其添加到电子表格中的VBA模块，然后使用.xlsm扩展名保存工作簿即可对其进行testing。 然后你可以在A1单元格中键入=nextPerm("abcd") ，它应该给你下一个排列 – "abdc" 。 在A2中键入=nextPerm(A1)将计算出后面的那个，等等。您可以一直沿着电子表格复制，并获取每个值。

如果将单元格复制到超出最后一个排列的范围，它将首次返回"**done**"作为值; 当你input"**done**"作为input时，它将返回空白。 这使得事情明显停止的地方。

Answer 2

看看这个函数 – 它将使用recursion列出一组数字的所有可能的排列。 http://www.vb-helper.com/howto_permute.html

这是VB6但它也应该基本上在Excel's VBA Excel's实施工作。

无论如何，我知道我不应该在回答这里的其他评论，我真的很抱歉。 只是作者西蒙娜·S（Simone S）说：“如果任何人有兴趣使用结果函数就问我”，然而除此之外，没有办法联系到这个人。 Simone，请问，我一直在寻找Shapley-Shubik algorithm几个小时。 请你指点一下如何计算索引或结果函数的描述？