w3hello.com logo
Home PHP C# C++ Android Java Javascript Python IOS SQL HTML videos Categories
Generate all possible combinations of choices from mutually exclusive options

In this Experts-Exchange PAQ http://rdsrc.us/qdl6tl I worked on a very similar problem to enumerate every combination of five different categories of things. The number of things in each category varied. The enumeration had to consider the possibility of no selection in a category as well as any one selection drawn from that category.

I approached the problem as writing a five digit number, where the number of possible digits at each position in the number was a variable.

Sub CombinatrixPlus()
'Forms all the combinations of at least two subattributes taken from a
selection. _
    No more than one subattribute may be taken from any row.
'Uses variable base counting method

Dim i As Long, ii As Long, j As Long, k As Long, lenSep As Long, _
    m As Long, mCol As Long, mSheet As Long, mRow As Long, _
    N As Long, nBlock As Long, nMax As Long, nWide As Long
Dim v As Variant, vInputs As Variant, vResults As Variant
Dim rg As Range, rgDest As Range
Dim ws As Worksheet
Dim s As String, sep As String

Application.ScreenUpdating = False
sep = ", "      'Separator substring between each subattribute in results
Set ws = Worksheets("Sheet2")   'Put first batch of results in this
worksheet
Set rgDest = ws.[A2]      'Put results starting in this cell
mSheet = rgDest.Worksheet.Index
mCol = rgDest.Column
lenSep = Len(sep)
Set rg = Selection      'Cells containing the subattributes
nBlock = 16384          'Maximum number of values in results array

'Clear the previous results
Application.DisplayAlerts = False
For i = Worksheets.Count To ws.Index Step -1
    Worksheets(i).Cells.Clear                   'Clear the cells
    If i > ws.Index Then Worksheets(i).Delete   'Delete the sheet
Next
Application.DisplayAlerts = True

N = rg.Rows.Count
nWide = N       'If results lists subattributes in separate cells
'nWide = 1      'If results lists subattributes as a single string with
separators
ReDim v(N, 1 To 2)
vInputs = rg.Value
v(0, 2) = 1
For i = 1 To N
    v(i, 1) = Application.CountA(rg.Rows(i))
    v(i, 2) = (v(i, 1) + 1) * v(i - 1, 2)
Next
nMax = v(N, 2) - 1


ReDim vResults(1 To nBlock, 1 To nWide)
For i = 1 To nMax
    s = ""
    m = 0
    ii = ii + 1
    For j = 1 To N
        k = (i Mod v(j, 2))  v(j - 1, 2)
        If k <> 0 Then
            m = m + 1
            If nWide > 1 Then vResults(ii, j) = vInputs(j, k)
            s = s & sep & vInputs(j, k)
        End If
    Next
    s = Mid$(s, lenSep + 1)
    If nWide = 1 Then vResults(ii, 1) = s  'Results in a concatentated
string
    If m < 2 Then ii = ii - 1

    If ii = nBlock Then
        Application.StatusBar = "Now posting combination " & i & "
of " & nMax
        mRow = rgDest.Worksheet.Cells(Rows.Count, mCol).End(xlUp).Row
        If rgDest.Worksheet.Cells(mRow, mCol) <> "" Then mRow = mRow
+ 1
        If mRow < rgDest.Row Then mRow = rgDest.Row
        If (Rows.Count - mRow) >= nBlock Then
            rgDest.Worksheet.Cells(mRow, mCol).Resize(nBlock, nWide).Value
= vResults
        Else
            mSheet = mSheet + 1
            If Worksheets.Count < mSheet Then Worksheets.Add
After:=Worksheets(mSheet - 1)
            With ActiveSheet
                Set rgDest = .Range(rgDest.Address)
                For j = 1 To N
                    .Columns(j).ColumnWidth = ws.Columns(j).ColumnWidth
                Next
                mRow = rgDest.Row
                .Cells(mRow, mCol).Resize(nBlock, nWide).Value = vResults
            End With
        End If
        ii = 0
        ReDim vResults(1 To nBlock, 1 To nWide)
    End If
Next

If ii > 0 Then
        Application.StatusBar = "Now posting combination " & i & "
of " & nMax
        mRow = rgDest.Worksheet.Cells(Rows.Count, mCol).End(xlUp).Row
        If rgDest.Worksheet.Cells(mRow, mCol) <> "" Then mRow = mRow
+ 1
        If mRow < rgDest.Row Then mRow = rgDest.Row
        If (Rows.Count - mRow) >= nBlock Then
            rgDest.Worksheet.Cells(mRow, mCol).Resize(nBlock, nWide).Value
= vResults
        Else
            mSheet = mSheet + 1
            If Worksheets.Count < mSheet Then Worksheets.Add
After:=Worksheets(mSheet - 1)
            With ActiveSheet
                Set rgDest = .Range(rgDest.Address)
                For j = 1 To N
                    .Columns(i).ColumnWidth = ws.Columns(j).ColumnWidth
                Next
                mRow = rgDest.Row
                .Cells(mRow, mCol).Resize(nBlock, nWide).Value = vResults
            End With
        End If
    i = rgDest.Worksheet.UsedRange.Rows.Count   'Reset the scrollbar
End If
Application.StatusBar = False   'Clear the status bar
Application.ScreenUpdating = True
End Sub




© Copyright 2018 w3hello.com Publishing Limited. All rights reserved.