Question

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

下面是选择所有N选择2个数组大小为N的子集的简单代码。

希望增加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

除了格雷码算法，您还可以利用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}

Answer 2

我前一段时间（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

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

2 个答案: