Question

我需要一个代码，可以从数组中的一组元素中给出一个唯一组合的列表，如下所示：

假设myArray包含[A B C]
因此，输出必须是：

一个
乙
ç
A B
A C
B C
A B C

或

A B C
B C
A C
A B
一个
乙
C

对我来说输出都是正常的（以1组合开始，然后是2种组合，以所有组合结束，反之亦然）。
字母的位置并不重要，同一组合类型中的字母顺序也不重要。

我在'Dick Kusleika'的帖子中找到了一个建议：Creating a list of all possible unique combinations from an array (using VBA)但是当我尝试时，并没有向我提出我想要的安排。

我还在一个帖子中找到了'pgc01'的建议：http://www.mrexcel.com/forum/excel-questions/435865-excel-visual-basic-applications-combinations-permutations.html它给了我我想要的安排，然而，这些组合没有被填充在一个数组中但是它被填充在excel中相反，使用每个组合的循环。

所以，我希望组合的安排就像'pgc01'建议的那样，并且像Dick Kusleika所呈现的那样被填充在数组中。

任何人都可以提供帮助？欣赏它。

Answer 1

从这里开始：

Sub TestRoutine()
    Dim inputt() As String, i As Long
    Dim outputt As Variant
    inputt = Split("A B C", " ")
    outputt = Split(ListSubsets(inputt), vbCrLf)
    For i = LBound(outputt) + 2 To UBound(outputt)
        MsgBox i & vbTab & outputt(i)
    Next i
End Sub


Function ListSubsets(Items As Variant) As String
    Dim CodeVector() As Long
    Dim i As Long
    Dim lower As Long, upper As Long
    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

请注意，我们会丢弃输出数组的前两个元素。

使用VBA的数组中的唯一组合

1 个答案: