从数组中创建所有可能的唯一组合列表（使用VBA）

Question

背景：我将所有字段名称从数据库中提取到数组中 - 我已经完成了这部分工作，没有问题，所以我已经有一个包含所有字段（allfields（））的数组，并且有多少字段（numfields）的计数。

我现在试图编译所有可以从这些不同的字段名称组成的独特组合。例如，如果我的三个字段名称，DESCR，日期，我会想返回以下内容：

• 名称，DESCR，DATE
• 名称，DESCR
• 名称，日期
• DESCR， DATE
• NAME
• DESCR
• DATE

我已经尝试了几个不同的东西，包括多个嵌套循环，并修改了这里的答案：How to make all possible sum combinations from array elements in VB以适应我的需求，但似乎我没有访问必要的库（System或System.Collections。通用）在我的工作PC上，因为它只有VBA。

有没有人有一些VB代码踢，会达到这个目的？

非常感谢！

Answer 1

几年前我有类似的要求。我不记得为什么，我不再有代码，但我记得算法。对我来说这是一次性练习，所以我想要一个简单的代码。我并不在乎效率。

我将假设一个基于数组，因为它使得一个稍微简单的解释。由于VBA支持基于一个数组，所以这应该是确定的，但如果这是您想要的，则可以轻松调整基于零的数组。

AllFields（1到NumFields）包含名称。

有一个循环：对于INX = 1到2^NumFields - 1

在循环内考虑INX与位的二进制数编号为1至NumFields。对于1到NumFields之间的每个N，如果N是1，那么在这个组合中包含AllFields（N）。

这个循环产生2^NumFields - 1个组合：

Names: A B C 

Inx:   001 010 011 100 101 110 111 

CombinationS: C B BC A A C AB ABC 

与VBA越来越位N的值。

额外部分

对于具有每个人唯一的困难在执行我的算法时，我想我最好说明我会如何做到这一点。

由于我们尚未被告知名称中可能包含哪些字符，因此我已经填充了一组测试数据和一组令人讨厌的字段名称。

子程序GenerateCombinations完成业务。我是递归的粉丝，但我认为我的算法不够复杂，无法证明它在这种情况下的使用。我将结果返回到一个锯齿状的数组，我更喜欢串联。 GenerateCombinations的输出被输出到立即窗口以显示其输出。

Option Explicit 

这个例程演示GenerateCombinations

Sub Test() 

    Dim InxComb As Integer 
    Dim InxResult As Integer 
    Dim TestData() As Variant 
    Dim Result() As Variant 

    TestData = Array("A A", "B,B", "C|C", "D;D", "E:E", "F.F", "G/G") 

    Call GenerateCombinations(TestData, Result) 

    For InxResult = 0 To UBound(Result) 
    Debug.Print Right(" " & InxResult + 1, 3) & " "; 
    For InxComb = 0 To UBound(Result(InxResult)) 
     Debug.Print "[" & Result(InxResult)(InxComb) & "] "; 
    Next 
    Debug.Print 
    Next 

End Sub 

GenerateCombinations做业务。

Sub GenerateCombinations(ByRef AllFields() As Variant, _ 
              ByRef Result() As Variant) 

    Dim InxResultCrnt As Integer 
    Dim InxField As Integer 
    Dim InxResult As Integer 
    Dim I As Integer 
    Dim NumFields As Integer 
    Dim Powers() As Integer 
    Dim ResultCrnt() As String 

    NumFields = UBound(AllFields) - LBound(AllFields) + 1 

    ReDim Result(0 To 2^NumFields - 2) ' one entry per combination 
    ReDim Powers(0 To NumFields - 1)   ' one entry per field name 

    ' Generate powers used for extracting bits from InxResult 
    For InxField = 0 To NumFields - 1 
    Powers(InxField) = 2^InxField 
    Next 

For InxResult = 0 To 2^NumFields - 2 
    ' Size ResultCrnt to the max number of fields per combination 
    ' Build this loop's combination in ResultCrnt 
    ReDim ResultCrnt(0 To NumFields - 1) 
    InxResultCrnt = -1 
    For InxField = 0 To NumFields - 1 
     If ((InxResult + 1) And Powers(InxField)) <> 0 Then 
     ' This field required in this combination 
     InxResultCrnt = InxResultCrnt + 1 
     ResultCrnt(InxResultCrnt) = AllFields(InxField) 
     End If 
    Next 
    ' Discard unused trailing entries 
    ReDim Preserve ResultCrnt(0 To InxResultCrnt) 
    ' Store this loop's combination in return array 
    Result(InxResult) = ResultCrnt 
    Next 

End Sub 

Answer 2

建立Tony的答案： （其中，A = 4，B = 2，C = 1）

（以下为伪代码）

If (A And Inx <> 0) then 
    A = True 
end if 

Answer 3

这里的一些代码，将做你想做的事。它为每个元素分配一个零或一个，并加入被分配一个元素的元素。例如，有四个元素，你有2^4个组合。表示为0和1它看起来像

0000 
0001 
0010 
0100 
1000 
0011 
0101 
1001 
0110 
1010 
1100 
0111 
1011 
1101 
1110 
1111 

此代码创建的阵列（maInclude），其复制这些场景的所有16个，并使用相应的mvArr元件来连接的结果。

Option Explicit 

Dim mvArr As Variant 
Dim maResult() As String 
Dim maInclude() As Long 
Dim mlElementCount As Long 
Dim mlResultCount As Long 

Sub AllCombos() 

    Dim i As Long 

    'Initialize arrays and variables 
    Erase maInclude 
    Erase maResult 
    mlResultCount = 0 

    'Create array of possible substrings 
    mvArr = Array("NAME", "DESC", "DATE", "ACCOUNT") 

    'Initialize variables based on size of array 
    mlElementCount = UBound(mvArr) 
    ReDim maInclude(LBound(mvArr) To UBound(mvArr)) 
    ReDim maResult(1 To 2^(mlElementCount + 1)) 

    'Call the recursive function for the first time 
    Eval 0 

    'Print the results to the immediate window 
    For i = LBound(maResult) To UBound(maResult) 
     Debug.Print i, maResult(i) 
    Next i 

End Sub 


Sub Eval(ByVal lPosition As Long) 

    Dim sConcat As String 
    Dim i As Long 

    If lPosition <= mlElementCount Then 
     'set the position to zero (don't include) and recurse 
     maInclude(lPosition) = 0 
     Eval lPosition + 1 

     'set the position to one (include) and recurse 
     maInclude(lPosition) = 1 
     Eval lPosition + 1 
    Else 
     'once lPosition exceeds the number of elements in the array 
     'concatenate all the substrings that have a corresponding 1 
     'in maInclude and store in results array 
     mlResultCount = mlResultCount + 1 
     For i = 0 To UBound(maInclude) 
      If maInclude(i) = 1 Then 
       sConcat = sConcat & mvArr(i) & Space(1) 
      End If 
     Next i 
     sConcat = Trim(sConcat) 
     maResult(mlResultCount) = sConcat 
    End If 

End Sub 

递归让我头疼，但它确实很强大。此代码由Naishad Rajani改编而成，其原始代码可在http://www.dailydoseofexcel.com/archives/2005/10/27/which-numbers-sum-to-target/