【问题标题】:Creating a list of all possible unique combinations from an array (using VBA)从数组中创建所有可能的唯一组合的列表(使用 VBA)
【发布时间】:2012-01-06 15:28:12
【问题描述】:

背景:我正在将数据库中的所有字段名称提取到一个数组中 - 我已经完成了这部分没有问题,所以我已经有了一个包含所有字段 (allfields()) 的数组并且我有有多少字段的计数(numfields)。

我现在正在尝试编译所有可以由这些不同字段名称组成的独特组合。例如,如果我的三个字段是 NAME、DESCR、DATE,我想返回以下内容:

  • 姓名、描述、日期
  • 姓名,描述
  • 姓名,日期
  • 描述,日期
  • 姓名
  • 描述
  • 日期

我为此尝试了一些不同的方法,包括多个嵌套循环,并在此处修改答案:How to make all possible sum combinations from array elements in VB 以满足我的需要,但似乎我无法访问必要的库(系统或System.Collections.Generic)在我的工作 PC 上,因为它只有 VBA。

有没有人有一些 VB 代码可以实现这个目的?

非常感谢!

【问题讨论】:

  • 您这样做是为了达到什么目的?深入了解问题试图实现的目标通常会导致更好地实现该目标。
  • 我将它与来自会计数据库的总账一起使用,其中 GL 本身没有可用于隔离特定交易的交易标识符/唯一 ID 字段。所以我要做的是找到最合适的字段组合来创建这样一个唯一的 ID 字段,而不必自己手动测试所有可能的组合。
  • 因此,您正在寻找 current 数据指示唯一的字段组合,而不是 domain 指示的一组字段是独特的?这听起来像是灾难的秘诀。如果您选择一组字段作为标识符,但事实证明它不是在路上,您可能会发现自己陷入了痛苦的世界。
  • 我有另一个程序可以用来确定特定组合是否唯一 - 它根据标识符获取每笔交易并将它们全部汇总,然后计算平衡交易的数量和百分比为零。余额为零的交易越多,标识符就越好。所以这不是问题 - 只需编译字段名称的所有唯一组合的列表,然后我就可以很容易地从那里工作。
  • 您使用的是 vb.net 还是 VBA?

标签: arrays vba combinations


【解决方案1】:

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

我将假设基于 1 的数组,因为它使解释稍微容易一些。由于 VBA 支持从 1 开始的数组,这应该没问题,尽管如果你想要的话,它可以很容易地调整到从 0 开始的数组。

AllFields(1 To NumFields) 保存名称。

有一个循环:对于 Inx = 1 To 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 的唯一困难是获取 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

【讨论】:

    【解决方案2】:

    这里有一些代码可以满足您的需求。它为每个元素分配一个零或一,并将分配了一个的元素连接起来。例如,对于四个元素,您有 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/ 找到

    【讨论】:

    • 我认为创建一个与早期答案重复的答案是不合适的。你声称抄袭了别人的算法,而不是我的,但我不认为这是一个借口。
    • @TonyDallimore:这是您的解决方案的副本吗?唯一表面上的相似之处是使用 0 和 1 来表示布尔值(包括/不包括字段名称),这是该问题的通用部分。
    • @Jean-François Corbett。我相当苦涩的评论背后有两个因素。 (1) 昨天我看到一个问题的答案作为评论。大约一个小时后,有人复制了评论作为答案。我认为这是一次赤裸裸的企图窃取别人的信用和积分。 (2) 我昨晚很晚(今天早上)完成了工作,我在睡觉前对 Stack Overflow 进行了最后检查。我看到乍一看似乎是我的算法的粗略实现,没有信用。因此,我的苦涩评论。
    • 我一直是竞争对手答案的作者。有时,我们中的两个人显然已经花时间创建了一个详细的答案,我们在对方不知情的情况下发布了该答案。如果我在首先看到较早的答案时发布了竞争对手的答案,我承认先前的答案并解释我为什么要发布竞争对手。也许我认为我的回答更胜一筹;更多情况下,它只是不同,并希望提醒 OP 可能更合适的替代方法。我认为承认和解释是必要的礼貌。
    • @TonyDallimore 感谢您的优雅撤回。虽然我当然理解您的沮丧,但我发现在我参与的“常客”论坛中,通常会为可接受的内容定下基调,这通常在 Excel 空间中比整个论坛的标准更高。违规者往往是网站新手,或不定期的贡献者,我认为在这种情况下,检查迪克的记录可能会重新调整你的烦恼。
    【解决方案3】:

    以托尼的回答为基础: (其中 A = 4,B = 2,C = 1)

    (以下为伪代码)

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

    【讨论】:

      猜你喜欢
      • 2014-09-07
      • 1970-01-01
      • 1970-01-01
      • 1970-01-01
      • 2012-05-28
      • 2020-02-29
      • 1970-01-01
      • 2018-08-08
      • 1970-01-01
      相关资源
      最近更新 更多