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

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

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

为了增加这个Nselect（N-1）…一直到Nselect1。

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

除了格雷码algorithm之外，还可以利用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），并从John Coleman那里得到了这个优秀的代码：

 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 

原来的问题和答案：

约翰·科尔曼