从数组中创建所有可能的唯一组合的列表（使用 VBA）
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/8760185/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Creating a list of all possible unique combinations from an array (using VBA)
提问by dmacp
Background: I'm pulling all of the field names from a database into an array - I've got this part done without a problem, so I already have an array containing all the fields (allfields()) and I have a count of how many fields there are (numfields).
背景：我正在将数据库中的所有字段名称提取到一个数组中 - 我已经毫无问题地完成了这部分，所以我已经有了一个包含所有字段 (allfields()) 的数组，并且我有一个计数有多少个字段（numfields）。
I am now trying to compile all of the unique combinations that can be made from those various field names. For example, if my three fields are NAME, DESCR, DATE, I would want to return the following:
我现在正在尝试编译可以从这些不同的字段名称组成的所有独特组合。例如，如果我的三个字段是 NAME、DESCR、DATE，我想返回以下内容：
- NAME, DESCR, DATE
- NAME, DESCR
- NAME, DATE
- DESCR, DATE
- NAME
- DESCR
- DATE
- 名称、描述、日期
- 名称、描述
- 名称日期
- 描述，日期
- 姓名
- 描述
- 日期
I've tried a few different things for this, including multiple nested loops, and modifying the answer here: How to make all possible sum combinations from array elements in VBto fit my needs, but it appears as though I do not have access to the necessary libaries (System or System.Collections.Generic) on my work PC, as it only has VBA.
我为此尝试了一些不同的方法，包括多个嵌套循环，并在此处修改答案：How to make all possible sum combination from array elements in VBto fit my needs，但似乎我无权访问我的工作 PC 上的必要库（System 或 System.Collections.Generic），因为它只有 VBA。
Does anyone have a bit of VB code kicking around that would fulfill this purpose?
有没有人有一些 VB 代码可以实现这个目的？
Thanks a lot!
非常感谢！
回答by Tony Dallimore
I had a similar requirement some years ago. I do not remember why and I no longer have the code but I do remember the algorithm. For me this was a one-off exercise so I wanted an easy code. I did not care about efficiency.
几年前我也有类似的要求。我不记得为什么，我不再有代码，但我记得算法。对我来说，这是一次性练习，所以我想要一个简单的代码。我不关心效率。
I will assume one-based arrays because it makes for a marginally easier explanation. Since VBA supports one-based arrays, this should be OK although it is an easy adjustment to zero-based arrays if that is what you want.
我将假设基于一个的数组，因为它使解释稍微容易一些。由于 VBA 支持基于 1 的数组，因此这应该没问题，尽管如果您想要的话，可以轻松调整到基于零的数组。
AllFields(1 To NumFields) holds the names.
AllFields(1 To NumFields) 保存名称。
Have a Loop: For Inx = 1 To 2^NumFields - 1
有一个循环：对于 Inx = 1 到 2^NumFields - 1
Within the loop consider Inx as a binary number with bits numbered 1 to NumFields. For each N between 1 and NumFields, if bit N is one include AllFields(N) in this combination.
在循环中，将 Inx 视为二进制数，位编号为 1 到 NumFields。对于 1 和 NumFields 之间的每个 N，如果位 N 为 1，则在此组合中包括 AllFields(N)。
This loop generates the 2^NumFields - 1 combinations:
此循环生成 2^NumFields - 1 个组合：
Names: A B C
Inx: 001 010 011 100 101 110 111
CombinationS: C B BC A A C AB ABC
The only difficulty with VBA is getting the value of Bit N.
VBA 的唯一困难是获取 Bit N 的值。
Extra section
额外部分
With everyone having at go at implementing bits of my algorithm, I thought I had better show how I would have done it.
由于每个人都在努力实现我的算法，我想我最好展示一下我是如何做到的。
I have filled an array of test data with an nasty set of field names since we have not been told what characters might be in a name.
我已经用一组令人讨厌的字段名称填充了一组测试数据，因为我们没有被告知名称中可能包含哪些字符。
The subroutine GenerateCombinations does the business. I am a fan of recursion but I do not think my algorithm is complicated enough to justify its use in this case. I return the result in a jagged array which I prefer to concatenation. The output of GenerateCombinations is output to the immediate window to demonstrate its output.
子程序 GenerateCombinations 完成这项工作。我是递归的粉丝，但我认为我的算法不够复杂，不足以证明在这种情况下使用它是合理的。我将结果返回到我更喜欢串联的锯齿状数组中。GenerateCombinations 的输出被输出到立即窗口以展示其输出。
Option Explicit
This routine demonstrates GenerateCombinations
此例程演示 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 does the business.
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
回答by Dick Kusleika
Here's some code that will do what you want. It assigns a zero or one to each element and joins up the elements that are assigned a one. With four elements, for example, you have 2^4 combinations. Represented as zeros and ones, it would look like
这是一些可以执行您想要的操作的代码。它为每个元素分配一个零或一个，并连接分配了一个 1 的元素。例如，对于四个元素，您有 2^4 种组合。表示为零和一，它看起来像
0000
0001
0010
0100
1000
0011
0101
1001
0110
1010
1100
0111
1011
1101
1110
1111
This code creates an array(maInclude) that replicates all 16 of those scenarios and uses the corresponding mvArr element to concatenate the results.
此代码创建了一个数组 (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
Recursion makes my head hurt, but it sure is powerful. This code was adapted from Naishad Rajani whose original code can be found at http://www.dailydoseofexcel.com/archives/2005/10/27/which-numbers-sum-to-target/
递归让我头疼，但它确实很强大。此代码改编自 Naishad Rajani，其原始代码可在http://www.dailydoseofexcel.com/archives/2005/10/27/which-numbers-sum-to-target/找到
回答by Harry
to build on Tony's answer: (where A = 4, B = 2, C = 1)
以托尼的答案为基础：（其中 A = 4，B = 2，C = 1）
(the following is pseudocode)
（以下为伪代码）
If (A And Inx <> 0) then
A = True
end if
