生成所有2^n个子集的列表

Question

我正在寻找VBA中的代码来生成传递数组中所有项的子集。

下面是简单的代码来选择所有N个选择的阵列大小N的子集2

寻找以扩大此对于N选择（N-1）...向下到N一路选择1.

Option Base 1 
Sub nchoose2() 

iarray = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12) 
n = UBound(iarray) 

x = 1 
t = 0 
r = 0 
Do While (n - x) >= 1 

    For i = 1 To (n - x) 
    Cells((i + t), 1) = iarray(x) 
    Cells((i + t), 2) = iarray(i + x) 

    Next i 



x = x + 1 
t = t + (n - (1 + r)) 
r = r + 1 
Loop 

End Sub 

Answer 1

我问过类似的问题而回（2005年），并收到了来自约翰·科尔曼这个优秀的代码：

Sub MAIN() 
    Dim i As Long, st As String 
    Dim a(1 To 12) As Integer 
    Dim ary 

    For i = 1 To 12 
     a(i) = i 
    Next i 

    st = ListSubsets(a) 
    ary = Split(st, vbCrLf) 

    For i = LBound(ary) To UBound(ary) 
     Cells(i + 1, 1) = ary(i) 
    Next i 
End Sub 

Function ListSubsets(Items As Variant) As String 
    Dim CodeVector() As Integer 
    Dim i As Integer 
    Dim lower As Integer, upper As Integer 
    Dim SubList As String 
    Dim NewSub As String 
    Dim done As Boolean 
    Dim OddStep As Boolean 

    OddStep = True 
    lower = LBound(Items) 
    upper = UBound(Items) 

    ReDim CodeVector(lower To upper) 'it starts all 0 
    Do Until done 
     'Add a new subset according to current contents 
     'of CodeVector 

     NewSub = "" 
     For i = lower To upper 
      If CodeVector(i) = 1 Then 
       If NewSub = "" Then 
        NewSub = Items(i) 
       Else 
        NewSub = NewSub & ", " & Items(i) 
       End If 
      End If 
     Next i 
     If NewSub = "" Then NewSub = "{}" 'empty set 
     SubList = SubList & vbCrLf & NewSub 
     'now update code vector 
     If OddStep Then 
      'just flip first bit 
      CodeVector(lower) = 1 - CodeVector(lower) 
     Else 
      'first locate first 1 
      i = lower 
      Do While CodeVector(i) <> 1 
       i = i + 1 
      Loop 
      'done if i = upper: 
      If i = upper Then 
       done = True 
      Else 
       'if not done then flip the *next* bit: 
       i = i + 1 
       CodeVector(i) = 1 - CodeVector(i) 
      End If 
     End If 
     OddStep = Not OddStep 'toggles between even and odd steps 
    Loop 
    ListSubsets = SubList 
End Function 

原来的问题和答案：

John Coleman

Answer 2

除了格雷码算法，您还可以利用n元素集的子集与长度为n的二元向量之间的对应关系。下面的代码说明了这种方法：

Sub AddOne(binaryVector As Variant) 
'adds one to an array consisting of 0s and 1s 
'thought of as a binary number in little-endian 
'the vector is modified in place 
'all 1's wraps around to all 0's 
    Dim bit As Long, carry As Long, i As Long, n As Long 
    carry = 1 
    n = UBound(binaryVector) 
    i = LBound(binaryVector) 
    Do While carry = 1 And i <= n 
     bit = (binaryVector(i) + carry) Mod 2 
     binaryVector(i) = bit 
     i = i + 1 
     carry = IIf(bit = 0, 1, 0) 
    Loop 
End Sub 


Function listSubsets(items As Variant) As Variant 
'returns a variant array of collections 
    Dim lb As Long, ub As Long, i As Long, j As Long, numSets As Long 
    Dim vect As Variant 'binary vector 
    Dim subsets As Variant 
    lb = LBound(items) 
    ub = UBound(items) 
    ReDim vect(lb To ub) 
    numSets = 2^(1 + ub - lb) 
    ReDim subsets(1 To numSets) 
    For i = 1 To numSets 
     Set subsets(i) = New Collection 
     For j = lb To ub 
      If vect(j) = 1 Then subsets(i).Add items(j) 
     Next j 
     AddOne vect 
    Next i 
    listSubsets = subsets 
End Function 

Function showCollection(c As Variant) As String 
    Dim v As Variant 
    Dim i As Long, n As Long 
    n = c.Count 
    If n = 0 Then 
     showCollection = "{}" 
     Exit Function 
    End If 
    ReDim v(1 To n) 
    For i = 1 To n 
     v(i) = c(i) 
    Next i 
    showCollection = "{" & Join(v, ", ") & "}" 
End Function 

Sub test() 
    Dim stooges As Variant 
    Dim stoogeSets As Variant 
    Dim i As Long 
    stooges = Array("Larry", "Curly", "Moe") 
    stoogeSets = listSubsets(stooges) 
    For i = LBound(stoogeSets) To UBound(stoogeSets) 
     Debug.Print showCollection(stoogeSets(i)) 
    Next i 
End Sub 

运行下面的输出代码的结果：

{} 
{Larry} 
{Curly} 
{Larry, Curly} 
{Moe} 
{Larry, Moe} 
{Curly, Moe} 
{Larry, Curly, Moe}