从互斥选项生成所有可能的选项组合

Question

我有一个优化问题，需要我测试潜在投资组合的所有潜在选择组合，我还需要能够快速适应以排除某些选择。

这必须在 Excel 中完成。

下面我的净化示例的规则：

• 我可以选择从 3 家杂货店中的任何一家购买水果
• 杂货店可能有不同数量的过道，以及可供选择的不同水果组合
• 我只能从所有杂货店中挑选一种水果（或根本没有选择）

组合

1. 我的第一个组合不是来自任何杂货店的水果
2. 接下来我从 Grocer3 的 Aisle 3 中挑选 apples
3. 然后 apples 来自 Aisle 2 来自 Grocer3
4. 然后 apples 来自 Aisle 1 来自 Grocer3
5. 然后我从 Grocer2 中的 Aisle 2 中挑选 apples 而从 Grocer 3 中什么都没有（即从 Grocer 3 中选择相同的选择 em> 作为组合 1 等）
6. 然后我从 Grocer2 的 Aisle 2 中挑选 apples，从 Aisle 3 中挑选 apples em> 来自 Grocer3（即来自 Grocer 3 的选择与组合 2 相同） 以此类推

所有这些将给我7*4*4 = 112 可能的组合，包括

• Grocer 1 的 7 个选项（6 个选项 + 1 个什么都不做）
• Grocer 2 的 4 个选项（3 个选项 + 1 个什么都不做）
• Grocer 3 的 4 个选项（3 个选项 + 1 个什么都不做）

1.无约束问题

我的实际问题要复杂得多，但基本结构是正确的。

我想做的是使用excel-formula 或vba 方法来填充以下所有可用选项：

1. 无约束问题。
2. 一个受限制的问题（例如，我关闭了 Aisle 2 给我 45 个有效组合）

2。受限问题

我的尝试

我确实解决了一个初始问题，即使用 MOD\INT 方法的杂货店选项数量相同。这很简单，只需一个公式即可，因为模式是可重复的。

如果有一个智能公式解决方案，那将是首选，但我对代码持开放态度（这是我现在正在尝试的路线）

Answer 1

在此 Experts-Exchange PAQ http://rdsrc.us/qdl6tl 中，我处理了一个非常相似的问题，以列举五种不同类别事物的每种组合。每个类别中的事物数量各不相同。枚举必须考虑在一个类别中没有选择的可能性以及从该类别中抽取的任何一个选择。

我把这个问题写成一个五位数的数字，其中数字中每个位置的可能位数是一个变量。

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