Question

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

这必须在Excel中完成。

以下我的消毒示例的规则：

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

组合

我的第一个组合是没有杂货店的水果
接下来我从 Grocer3

过道3

apples

然后苹果来自 Grocer3的过道2
然后苹果来自 Grocer3的过道1
然后我从 Grocer2 中的 Aisle 2 中选择 apples ，而从Grocer 3中选择 apple （即从 Grocer 3中选择 作为组合1等）
然后我从 Grocer2 中的 Aisle 2 中选择 apples ，从 Aisle 3中选择 apples 来自 Grocer3 （即与 Grocer 3 相同的选择作为组合2）等等。

所有这些都会给我7*4*4 = 112个可能的组合

Grocer 1 的7种选择（6种选择+ 1不做任何事）
Grocer 2 的4种选择（3种选择+ 1种无效）
Grocer 3 的4种选择（3种选择+ 1种无效）

1。无约束的问题 Unconstrained

我的实际问题要复杂得多，但基本结构也是如此。

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

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

2。约束问题 Unconstrained

我尝试了什么

我确实解决了一个初始问题，其中杂货店选项的数量与MOD\INT方法相同。由于模式是可重复的，因此单个公式很简单。

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

enter image description here

Answer 1

在这个专家交流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

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

1 个答案: