Как мне остановиться пораньше, если я чувствую себя комфортно, когда у меня есть около 1000 от окончательного решения в VBA?

Question

Я пытаюсь найти, какие числа в списке чисел складываются, чтобы сделать значение, указанное как rCell в коде. Для этого я использую решатель с суммой, который заставляет значения переменных ячеек быть двоичными.

Идея состоит в том, что после запуска решателя для первого набора переменных ячеек и RCell мы затем переходим к следующему и используем числа, которые еще не использовались.

Приведенный ниже код прекрасно работает, за исключением того, что это занимает много лет. Проблема, которую я обнаружил с указанием SolverOptions MaxTime:= k для некоторого целого числа 'k', заключается в том, что двоичное ограничение нарушено. Могу ли я в любом случае значительно ускорить этот процесс, чтобы дать представление о том, что у меня все в порядке с решением, составляющим примерно 1000 от конечного решения (которое обычно близко к разнице примерно в 1 или 2, если я позволяю ему пройти весь путь до конца) .

Спасибо!

Sub UtilStoch()    
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rInit As Range, rIter As Range, cell As Range
    Dim rChange As Variant, rCell As Variant

    Dim iBucket As Integer, i As Integer

    Set wb = Application.ThisWorkbook
    Set ws = wb.Sheets("Process")

    Set rInit = ws.Range("K5:K39")
    Set rIter = ws.Range("L5:L39")

    iBucket = 4      

    For i = 1 To iBucket
        rCell = ws.Range("M43").Offset(0, i - 1).Address
        rChange = ws.Range("M5:M39").Offset(0, i - 1).Address

        solverreset
        SolverOk SetCell:=rCell, MaxMinVal:=2, ValueOf:=0, ByChange:=rChange, _
            Engine:=3, EngineDesc:="Evolutionary"
        SolverAdd CellRef:=rChange, Relation:=5, FormulaText:="binary"
        SolverSolve True

        For Each cell In rIter
            If cell.Offset(0, i).Value = 1 Then
                cell.Offset(0, -2).Value = i
                cell.Value = 0
            End If
        Next cell
    Next i
End Sub