Creating a list of all possible unique combinations from an array (using VBA)

Question

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).

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
• 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 VB to 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.

Does anyone have a bit of VB code kicking around that would fulfill this purpose?

Thanks a lot!

Answer 1

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.

AllFields(1 To NumFields) holds the names.

Have a Loop: For Inx = 1 To 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.

This loop generates the 2^NumFields - 1 combinations:

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.

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.

Option Explicit

This routine demonstrates 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.

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

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

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.

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/

Answer 3

to build on Tony's answer: (where A = 4, B = 2, C = 1)

(the following is pseudocode)

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