从多个集创建所有可能的组合

Question

我对数学知识有限，所以如果我弄错的话，请原谅这些条款。我需要从多个集合中创建所有可能的组合，并且该集合中包含至少一个项目。

 - SetA: [1, 2, 3, 4, 5, 6, 7] 
 - SetB: [a, b, c, d] 
 - SetC: [!, @, #, $, %]

示例输出：

 - [1,a,!]
 - [1,2,a,c,@]
 - [1,2,3,4,5,6,7,a,b,c,d,!,@,#,$,%]

是否有一个特定的组合公式，因为我只能提出嵌套循环，我不确定它是否是正确的。

Answer 1

@barrycarter很想知道获得power set。但是，我们不需要拒绝任何东西，因为我们没有获得集合并集的功率集（这最终会效率低下，因为随着集合数量的增加会有很多拒绝）。我们只需获得每组的功率集，然后获得这些功率组的所有组合。下面的子程序适用于任意长度的任意数组。

Sub CreateAllCombs()

Dim ArrayOfPowSets() As Variant, mySet() As Variant, ArrCounter() As Long, myPS As Variant
Dim myCombs() As Variant, nextComb() As Variant, ParentComb() As Variant, ArrMax() As Long
Dim i As Long, j As Long, k As Long, count1 As Long, count2 As Long, CombExist As Boolean
Dim tempCol As Long, myMax As Long, maxRow As Long, totalCombs As Long

   With ActiveSheet
        maxRow = .Cells(.Rows.count, "A").End(xlUp).Row
    End With

   ReDim ArrayOfSets(1 To maxRow, 1 To 1)
   ReDim ArrCounter(1 To maxRow)
   ReDim ArrMax(1 To maxRow)
   myMax = 0

    For i = 1 To maxRow
        With ActiveSheet
            tempCol = .Cells(i, .Columns.count).End(xlToLeft).Column
        End With
        ReDim mySet(1 To tempCol)
        For j = 1 To tempCol: mySet(j) = Cells(i, j): Next j
        myPS = PowerSet(mySet)
        ArrMax(i) = UBound(myPS)
        If ArrMax(i) > myMax Then
            myMax = ArrMax(i)
            ReDim Preserve ArrayOfPowSets(1 To maxRow, 1 To ArrMax(i))
        End If
        For j = 1 To ArrMax(i)
            ArrayOfPowSets(i, j) = myPS(j)
        Next j
        ArrCounter(i) = 1
    Next i

    CombExist = True
    totalCombs = 0

    Do While CombExist
        count1 = 1
        ReDim ParentComb(1 To 1)

        For i = 1 To maxRow - 1
            For j = 1 To UBound(ArrayOfPowSets(i, ArrCounter(i)))
                ReDim Preserve ParentComb(1 To count1)
                ParentComb(count1) = ArrayOfPowSets(i, ArrCounter(i))(j)
                count1 = count1 + 1
            Next j
        Next i

        For i = 1 To ArrMax(maxRow)
            count2 = count1
            nextComb = ParentComb
            For j = 1 To UBound(ArrayOfPowSets(maxRow, i))
                ReDim Preserve nextComb(1 To count2)
                nextComb(count2) = ArrayOfPowSets(maxRow, i)(j)
                count2 = count2 + 1
            Next j
            totalCombs = totalCombs + 1
            ReDim Preserve myCombs(1 To totalCombs)
            myCombs(totalCombs) = nextComb
        Next i

        k = maxRow - 1

        Do While (ArrCounter(k) >= ArrMax(k))
            ArrCounter(k) = 1
            k = k - 1
            If k = 0 Then Exit Do
        Loop

        If k > 0 Then ArrCounter(k) = ArrCounter(k) + 1 Else CombExist = False

    Loop

    Sheets("Sheet2").Select

    For i = 1 To totalCombs
        For j = 1 To UBound(myCombs(i))
            Cells(i, j) = myCombs(i)(j)
        Next j
    Next i

End Sub

我使用了John Coleman编写的功率集函数的略微修改版本找到了here

Function PowerSet(Items As Variant) As Variant

    Dim PS As Variant
    Dim i As Long, j As Long, k As Long, n As Long
    Dim subset() As Variant

    n = UBound(Items)
    ReDim PS(1 To 1 + 2 ^ n - 2)
    For i = 1 To 2 ^ n - 1
        ReDim subset(1 To n)
        k = 0
        For j = 0 To n - 1
            If i And 2 ^ j Then
                k = k + 1
                subset(k) = Items(j + 1)
            End If
        Next j
        ReDim Preserve subset(1 To k)
        PS(i) = subset
    Next i

    PowerSet = PS

End Function

这假设SetA在第1行，SetB在第2行，等等。观察：

此外，应警告读者，这可能需要一段时间，因为有超过1400万种可能的组合。

(2^3 - 1) * (2^5 - 1) * (2^16 - 1) = 7 * 31 * 65535 = 14221095

此外，所有组合都通常写入Sheet2。

Answer 2

我想我发现我的解决方案请验证。

首先，对于每个集合，我创建了所有可能的组合，并使用pascal三角形的总和检查长度，而不使用null或此公式：

n！/（r！（n-r）！） - 1

EG

SetB：[a，b，c，d] - > [a，b，c，d，ab，ac，ad，bc，bd，cd，abc，abd，acd，bcd，abcd]

在为每个集创建所有可能的组合之后，我只使用了产品规则

[SetA] X [SetB] X [SetC]

这导致所有可能的组合：

• 多个项目
• 多套
• 不重复
• 没有订单

参考：https://www.mathsisfun.com/combinatorics/combinations-permutations-calculator.html

EDIT1：检查每组的组合量也可以是（2 ^ n）-1，其中n =组的长度

Answer 3

您是否尝试过使用嵌套for循环。

Sub Hello()
    MsgBox ("Hello, world!")

    Dim arr1
    arr1 = Array("1", "2", "3")

    Dim arr2
    arr2 = Array("a", "b", "c")

    Dim arr3
    arr3 = Array("!", "@", "$")

    For i = 0 To UBound(arr1)
        For j = 0 To UBound(arr2)
            For k = 0 To UBound(arr3)
                MsgBox (arr1(i) & arr2(j) & arr3(k))
            Next
        Next
    Next
End Sub