Question

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

我现在正在尝试编译可以从各种字段名称中创建的所有唯一组合。例如，如果我的三个字段是NAME，DESCR，DATE，我想返回以下内容：

NAME，DESCR，DATE
NAME，DESCR
NAME，DATE
DESCR，DATE
NAME
DESCR
DATE

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

有没有人有一些可以实现此目的的VB代码？

非常感谢！

Answer 1

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

我将假设基于单一的数组，因为它使得解释更容易。由于VBA支持基于一个阵列，所以这应该没问题，尽管如果这是你想要的，它可以轻松调整到基于零的数组。

AllFields（1 To NumFields）包含名称。

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

在循环内，将Inx视为二进制数，其编号为1到NumFields。对于1和NumField之间的每个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唯一的难点是获得Bit 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

这里有一些代码可以满足您的需求。它为每个元素分配一个零或一个，并连接分配了一个元素的元素。例如，使用四个元素，您有2 ^ 4个组合。代表为0和1，它看起来像

此代码创建一个数组（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/

找到

Answer 3

以Tony的答案为基础：（其中A = 4，B = 2，C = 1）

（以下是伪代码）

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

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

3 个答案: