Generate all possible combinations given a variable number of columns

[450nick]

Hi all!

I have an input range where I can have up to 10 rows containing data, and this is repeated on up to 10 columns. so maximum input cells is 10x10 = 100. What I'm trying to do, is generate a list, of all possible combinations when picking one item from each of the available columns. I have this example macro that seems quite neat, but it doesn't quite work and I can't work out why. I'm looking for some help to either identify the error in this code, or show me a more efficient way to do this. I initially tried with a series of nested loops, but the changing number of columns got me stumped!

Thanks! Nick

Example code:

Sub ListCombinations()

Dim col As New Collection
Dim c As Range, sht As Worksheet, res
Dim i As Long, arr, numCols As Long

    Set sht = ActiveSheet
    For Each c In sht.Range("A1:J1").Cells
        col.Add Application.Transpose(sht.Range(c, c.End(xlDown)))
        numCols = numCols + 1
    Next c

    res = Combine(col, "~~")

    For i = 0 To UBound(res)
        arr = Split(res(i), "~~")
        sht.Range("H1").Offset(i, 0).Resize(1, numCols) = arr
    Next i

End Sub


'create combinations from a collection of string arrays
Function Combine(col As Collection, SEP As String) As String()

    Dim rv() As String
    Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
    Dim t As Long, i As Long, n As Long, ub As Long
    Dim numIn As Long, s As String, r As Long

    numIn = col.Count
    ReDim pos(1 To numIn)
    ReDim lbs(1 To numIn)
    ReDim ubs(1 To numIn)
    ReDim lengths(1 To numIn)
    t = 0
    For i = 1 To numIn  'calculate # of combinations, and cache bounds/lengths
        lbs(i) = LBound(col(i))
        ubs(i) = UBound(col(i))
        lengths(i) = (ubs(i) - lbs(i)) + 1
        pos(i) = lbs(i)
        t = IIf(t = 0, lengths(i), t * lengths(i))
    Next i
    ReDim rv(0 To t - 1) 'resize destination array

    For n = 0 To (t - 1)
        s = ""
        For i = 1 To numIn
            s = s & IIf(Len(s) > 0, SEP, "") & col(i)(pos(i)) 'build the string
        Next i
        rv(n) = s

        For i = numIn To 1 Step -1
            If pos(i) <> ubs(i) Then   'Not done all of this array yet...
                pos(i) = pos(i) + 1    'Increment array index
                For r = i + 1 To numIn 'Reset all the indexes
                    pos(r) = lbs(r)    '   of the later arrays
                Next r
                Exit For
            End If
        Next i
    Next n

    Combine = rv
End Function

 

[mikerickson]

You're probably aware that 10^10 is a big number.

This will generate the results, but I'm not sure what you want to do with them

Sub test()
    Const Delimiter As String = ","
    Dim arrValues(1 To 10) As Variant
    Dim arrIndexes(1 To 10) As Long
    Dim i As Long, Pointer As Long
    Dim oneResult As String, oneArray As Variant
    Dim colCount As Long: colCount = 10

    For i = 1 To colCount
        With Columns(i)
            arrValues(i) = Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp)).Value
        End With
        arrIndexes(i) = 1
    Next i
    
    Do
        Rem create one result
        oneResult = vbNullString
        For i = 1 To colCount
            oneArray = arrValues(i)
            oneResult = oneResult & Delimiter & oneArray(arrIndexes(i), 1)
        Next i
        oneResult = Mid(oneResult, Len(Delimiter) + 1)
        
        Rem display one result
        If MsgBox(oneResult & vbCr & "more?", vbYesNo) = vbNo Then Exit Sub
        
        Rem incriment indexes
        GoSub IncrimentIndexes
    Loop Until Pointer > colCount
Exit Sub
IncrimentIndexes:
    Pointer = 1
    Do
        arrIndexes(Pointer) = arrIndexes(Pointer) + 1
        If UBound(arrValues(Pointer), 1) < arrIndexes(Pointer) Then
            arrIndexes(Pointer) = 1
            Pointer = Pointer + 1
        Else
            Exit Do
        End If
    Loop Until colCount < Pointer
    Return
End Sub

 

[450nick]

Thanks Mike, yes you're correct, this could generate a lot of results, but in reality it is very unlikely that there will be values in all cells, instead probably 2-3 rows populated in up to 5 columns in typical use. The code you posted looks good, but just testing it on 2 columns with 2 rows of data each, it gives a lot of results with "" one or either side of the comma. I guess I want the code to only show results where there is something either side of the comma, so in this test there should be 4 results in total. I'll then need to add a little bit of code to store the results in an array and then paste them all down to the sheet for evaluation.

 

[mikerickson]

The code that I wrote will treat empty strings like other strings.
(Sometimes "" is a option)

For example, if the desired output was
AX
AY
BX
BY
X
Y

you could have one column "A";"B";"" and the next "X";"Y"

 

[450nick]

I'm struggling to get it to ignore empty strings - any advice?

 

[mikerickson]

You could do something like this

' BlankFlag as boolean
'...

Do
        Rem create one result
        oneResult = vbNullString
        BlankFlag = False
        For i = 1 To colCount
            oneArray = arrValues(i)
            BlankFlag = BlankFlag Or (oneArrya(arrIndexes(i),1) = vbNullString)
            oneResult = oneResult & Delimiter & oneArray(arrIndexes(i), 1)
        Next i
        oneResult = Mid(oneResult, Len(Delimiter) + 1)
        
        If Not BlankFlag Then
            Rem display one result
            If MsgBox(oneResult & vbCr & "more?", vbYesNo) = vbNo Then Exit Sub
        End If        

        Rem incriment indexes
        GoSub IncrimentIndexes
    Loop Until Pointer > colCount

 

[450nick]

Wow, that works really well - I had tried something similar but less elegant but it didn't work in all circumstances. This is really impressive and a style of VBA I've never seen before, I need to study it a little more to understand exactly what's going on but thanks very much for your help!

 

[mikerickson]

I'm glad to help.

 

[450nick]

Thanks

 

[450nick]

Hi Mike, sorry I'd like to expand this a little perhaps you can help some more...

Against each of the values that are currently considered in this code, there are 5 numbers. When building each unique combination line, I would like to have the first column show the case, delimited by " | ", then the 5 total scores in the following 5 columns. So an output might be "Daisy Chained Reservoirs | Single Heated Flowlines | Local FPSO" then "24 63 14 18 18". I'm trying to work out how to do this, but I guess when the combination is first constructed, the scoring also needs to be considered, but I can't see how to do this without totally screwing up the way you've designed the construction code.

Here's what I have currently (working well without the scoring):

Sub Generate_Cases()
    Const Delimiter As String = " | "
    Dim arrValues(1 To 10) As Variant
    Dim arrIndexes(1 To 10) As Long
    Dim i As Long, Pointer As Long
    Dim oneResult As String, oneArray As Variant
    Dim colCount As Long: colCount = 10 - WorksheetFunction.CountBlank(Range("AG1:AP1")) 'Cells(1, Columns.Count).End(xlToLeft).Column
    Dim BlankFlag As Boolean
    Dim Inv_Com As Variant
    ReDim OutputArray(0)
    ReDim InvalidArray(0)
    
    StartCol = 33
    
    Inv_Com = Worksheets("Concept Builder").Range("Invalid_Combos")
    
    For i = 1 To colCount
        With Columns(i + (StartCol - 1))
            'arrValues(i) = Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp)).Value
            r = .Find("*", LookIn:=xlValues, SearchDirection:=xlPrevious).Row
            arrValues(i) = Range(.Cells(1, 1), .Cells(r)).Value
        End With
        DelimiterCatch = DelimiterCatch & Delimiter
        arrIndexes(i) = 1
    Next i
    
Do
        Rem create one result
        oneResult = vbNullString
        BlankFlag = False
        For i = 1 To colCount
            oneArray = arrValues(i)
            BlankFlag = BlankFlag Or (oneArray(arrIndexes(i), 1) = vbNullString)
            oneResult = oneResult & Delimiter & oneArray(arrIndexes(i), 1)
        Next i
        oneResult = Mid(oneResult, Len(Delimiter) + 1)
        
        For j = LBound(Inv_Com) To UBound(Inv_Com)
            If InStr(1, oneResult, Inv_Com(j, 1)) > 0 And InStr(1, oneResult, Inv_Com(j, 7)) > 0 And Not Inv_Com(j, 1) = "" And Not Inv_Com(j, 7) = "" Then
                InvalidFlag = 1
            End If
        Next j
        
        If Not BlankFlag Then
            Rem display one result
            ReDim Preserve OutputArray(UBound(OutputArray) + 1)
            ReDim Preserve InvalidArray(UBound(InvalidArray) + 1)
            OutputArray(UBound(OutputArray) - 1) = oneResult
            If InvalidFlag = 1 Then InvalidArray(UBound(InvalidArray)) = "X": InvalidFlag = 0
            'If MsgBox(oneResult & vbCr & "more?", vbYesNo) = vbNo Then Exit Sub
        End If

        Rem incriment indexes
        GoSub IncrimentIndexes
    Loop Until Pointer > colCount
    
    Range(Cells(3, 44), Cells(UBound(InvalidArray) + 3, 44)) = WorksheetFunction.Transpose(InvalidArray)
    Range(Cells(3, 45), Cells(UBound(OutputArray) + 3, 45)) = WorksheetFunction.Transpose(OutputArray)
    
Exit Sub
IncrimentIndexes:
    Pointer = 1
    Do
        arrIndexes(Pointer) = arrIndexes(Pointer) + 1
        If UBound(arrValues(Pointer), 1) < arrIndexes(Pointer) Then
            arrIndexes(Pointer) = 1
            Pointer = Pointer + 1
        Else
            Exit Do
        End If
    Loop Until colCount < Pointer
    Return
End Sub