Question

我正在尝试将数据列表“a，b，c，d，e，....”组织成1,2,3 .... n个元素的所有可能组合。

例如：

A，B，C，d，E

a
b
c
d
e
a,b
a,c
a,d
a,e
b,c
b,d
d,e
...

等等。

到目前为止，我只遇到过编写代码的人，他们找到两组数据而不是一组数据。

你知道从哪里开始吗？

在我的脑海中，它将类似于以下内容，因此它将系统地运行，并停止任何重复的排列。所以基本上我会在另一个循环中运行一个循环4或5次不同的时间。

i
i+1
i+...n
i,j+1
.
.
.
i,j,k,l....

Answer 1

10年前我问了一个类似的问题，得到了约翰科尔曼的一个很好的答案：

Gray Code

这是他的解决方案：

'If you run TestThis, then for example the second message box returns
'
'{}
'dog
'dog , cat
'cat
'cat , mouse
'dog , cat, mouse
'dog , mouse
'mouse
'mouse , zebra
'dog , mouse, zebra
'dog , cat, mouse, zebra
'cat , mouse, zebra
'cat , zebra
'dog , cat, zebra
'dog , zebra
'zebra
'
'Hope this helps,
'
'John Coleman

'p.s. The algorithm used to generate the Gray code comes from the
'excellent book "Combinatorial Algorithms: Generation, Enumeration and
'Search " by Kreher and Stinson."

和代码：

Sub TestThis()
    Dim i As Integer
    Dim A(3 To 7) As Integer
    Dim B As Variant

    For i = 3 To 7
        A(i) = i
    Next i
    B = Array("dog", "cat", "mouse", "zebra")

    MsgBox ListSubsets(A)
    MsgBox ListSubsets(B)

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

Answer 2

我知道这个问题很旧，但是我在找到John Coleman的选择之前写了代码。

为了找到不同的等级组合（即2、3、4个项目的集合），我将项目列表放在带有标题的干净工作表的ColumnA中，并使用类似以下内容的名称进行调用：

Sub call_listcombos()
Dim sht as Worksheet, outrn As Range
Dim n As Integer, r As Integer, rto As Integer
Dim poslist()
Application.ScreenUpdating = False
Set sht = ActiveSheet
n = sht.Range("A1").CurrentRegion.Rows.Count - 1
poslist() = Application.Transpose(sht.Range("A2").Resize(n).Value2)
rto = 2
Do While Application.Combin(n, rto + 1) < 250000
  DoEvents
  rto = rto + 1
Loop
For r = 2 To rto
  Set outrn = sht.Range("A1").Offset(sht.Range("A1").CurrentRegion.Rows.Count)
  Call list_combos(poslist(), r, outrn)
Next r
Application.ScreenUpdating = True
End Sub

代码：

Private Sub list_combos(items() As Variant, r As Integer, outrange As Range)
'receives a 1-D variant array and outputs a single column with nCr combinations
'selecting r items without replacement... n > r > 1 :: integers
Dim n As Integer, i As Integer, ri As Integer, outi As Long
Dim comboindex(), comboitems()
n = UBound(items) - LBound(items) + 1
outi = Application.Combin(n, r)
'test output range
If outrange.Row + outi > 1000000 Then
  MsgBox "Too many combinations! Will not fit in output range."
  Exit Sub
End If
If Application.CountA(outrange.Resize(outi)) > 0 Then
  MsgBox "Output range is not empty!"
  Exit Sub
End If
'initialize combinations
ReDim comboindex(1 To r)
ReDim comboitems(1 To r)
For ri = 1 To r
  comboindex(ri) = LBound(items) + ri - 1 'sets comboindex's base to items' base
  comboitems(ri) = items(comboindex(ri))
Next ri
'loop combinations
ri = r
outi = 0
Do While comboindex(ri) <= UBound(items)
  DoEvents
  For i = comboindex(ri) To UBound(items)
    comboindex(ri) = i
    comboitems(ri) = items(comboindex(ri))
    outrange.Offset(outi).Value2 = Join(comboitems, ";")
    outi = outi + 1
  Next i
  ri = ri - 1
  Do While comboindex(ri) + 1 = comboindex(ri + 1)
    DoEvents
    If ri = 1 Then Exit Do
    ri = ri - 1
  Loop
  comboindex(ri) = comboindex(ri) + 1
  comboitems(ri) = items(comboindex(ri))
  Do While ri < r
    DoEvents
    ri = ri + 1
    comboindex(ri) = comboindex(ri - 1) + 1
    If comboindex(ri) > UBound(items) Then Exit Do
    comboitems(ri) = items(comboindex(ri))
  Loop
Loop
End Sub

在vba中查找列表的所有可能组合

2 个答案: