Excel 达到给定总目标的组合最短路径

我需要找出解决问题的最短路径。无论如何，我都不是程序员。我正试图在excel中实现这一点。我在这里读过其他几个关于这个问题的例子，但是我没有找到一个对我有帮助的答案。有人能帮我找到一个可以在excel中实现的解决方案吗

我有6个不同的垫片。我需要有一个快速的方法来确定这些垫片的最佳组合最少数量的垫片，以达到我的目标尺寸。如有必要，可使用多个垫片

White (51mm)
Black (44mm)
Blue (38mm)
Green (32mm)
Purple (26mm)
Orange (13mm)

例如：

Target - 83mm
Optimal solution: White - 1; Green - 1
Excel Solver solution: Blue - 1; Green - 1; Orange - 1

---

如果所有垫片尺寸只能为正，则一种解决方案可能是从目标值向后计算，并不断减去垫片尺寸的所有组合，直到减法结果为0，这表明已达到解决方案

以下代码存在问题：

基本上是蛮力，没有情报。 空间复杂度高，因此当搜索空间超过系统限制时，可能会出现内存不足错误。 目前，代码使用数组的索引和元素来计算是否找到了解决方案，但这也要求数组连续存储所有结果，即使是正在/将要跳过的结果。 另一种方法可能是在数组中同时存储元素和索引，这意味着在每次迭代后可以过滤索引元素对，以删除不会产生解决方案的元素。这样做意味着您需要存储两条信息—元素和索引，而不仅仅是元素中的一条，因此初始成本更高。然而，随着你深入搜索空间，这种方法可能会变得更有益。 另一种方法可能是以块的形式从磁盘读/写阵列，这样在任何给定时间都不必将整个阵列存储在内存中。这是一种内存友好的方法，但可能需要编写更多的代码，除非现有库/模块可用。 由于用于访问数组元素的所有索引都是Long类型，因此如果数组需要包含2147483647个以上的元素，则可能会收到溢出错误。这可以通过将所有索引变量声明为Double类型而不是Long类型来改进，尽管在这种情况下，覆盖如此大的搜索空间所需的时间可能是主要问题。 没有规范化，这意味着代码可能会尝试目标-白色间隔大小-黑色间隔大小，然后再尝试目标-黑色间隔大小-白色间隔大小；即使两次尝试的结果相同。换句话说，代码尝试了很多不需要的组合。 如果上一次迭代产生的值会使遍历当前路径进一步浪费时间，则代码尝试跳过组合，例如，如果上一次迭代产生的值为负数，或小于最小间隔大小的值。然而，这样做的代价是存储上一次迭代的结果。此外，代码在下一次迭代中再次执行所有这些检查，这是非常昂贵的，因为每次迭代的检查数量都会增加。 没有定期事件，因此如果解决方案存在于搜索空间的更深处，Excel可能会变得无响应。 最后一点与输出相关。将解决方案写回工作表时，代码不会清除单元格。这意味着，如果这一次的解决方案少于上次，则并非所有上次的解决方案都将被覆盖。也许您可以在运行代码之前以编程方式清除单元格。 您需要在TryToSolve过程中更改工作表名称和单元格引用，但代码本身是：

Option Explicit

Private Function ConvertRangeToArrayOfLongs(ByVal someRange As Range) As Long()
    Dim inputArray As Variant
    inputArray = someRange.Value

    Dim outputArray() As Long
    ReDim outputArray(1 To UBound(inputArray, 1))

    Dim arrayIndex As Long
    For arrayIndex = LBound(outputArray, 1) To UBound(outputArray, 1)
        outputArray(arrayIndex) = CLng(inputArray(arrayIndex, 1))
    Next arrayIndex

    ConvertRangeToArrayOfLongs = outputArray
End Function

Public Sub TryToSolve()
    ' Subroutine needs better name.

    Dim sourceSheet As Worksheet
    Set sourceSheet = ThisWorkbook.Worksheets("Sheet1") ' Mine was on Sheet1, change to whatever your sheet is called.

    Dim target As Long
    target = sourceSheet.Range("A3") ' Mine was in cell A3, change to wherever yours is

    Dim spacerSizesRange As Range
    Set spacerSizesRange = sourceSheet.Range("D3:D8") ' Mine were in this range. Change to wherever yours are

    Dim spacerSizes() As Long
    spacerSizes = ConvertRangeToArrayOfLongs(spacerSizesRange)

    Dim spacerQuantities As Collection
    Set spacerQuantities = GetMinimumSpacerQuantities(target:=target, spacerSizes:=spacerSizes)

    If spacerQuantities.Count = 0 Then
        MsgBox "No solution found within the search space." & vbNewLine & vbNewLine & " (If implementation is correct, then there is no combination of current spacer sizes which can produce the current target value.)"
        End
    End If

    ' The bit below doesn't clear any previous writes. So if there are fewer results than last time,
    ' not all of last time's values will be overwritten.
    Dim writeIndex As Long
    For writeIndex = 1 To spacerQuantities.Count
        spacerSizesRange.Offset(0, writeIndex).Value = Application.Transpose(spacerQuantities(writeIndex)) ' TRANSPOSE can only handle ~65k
    Next writeIndex
End Sub

Private Function GetMinimumSpacerQuantities(ByVal target As Long, ByRef spacerSizes() As Long) As Collection
    ' This function needs a better name.

    Dim countOfSpacers As Long
    countOfSpacers = UBound(spacerSizes) ' Assumed to be 1-based

    Dim smallestSpacer As Long ' Assumed to be whole number
    smallestSpacer = Application.RoundUp(Application.Min(spacerSizes), 0)

    Dim iterationLimit As Long ' Assuming no negative spacer sizes, solution must exist within this search space.
    iterationLimit = Application.RoundUp(target / smallestSpacer, 0)

    Dim outputCollection As Collection
    Set outputCollection = New Collection

    Dim iterationIndex As Long
    For iterationIndex = 1 To iterationLimit

        Dim currentResults() As Long
        Dim arrayToSubtract() As Long

        If iterationIndex > 1 Then
            arrayToSubtract = currentResults()
        Else
            arrayToSubtract = GetInitialisedNumericArray(lengthOfArray:=1, valueToInitialiseWith:=target)
        End If

        Const FLAG_VALUE As Long = -1
        currentResults = GetInitialisedNumericArray(lengthOfArray:=countOfSpacers ^ iterationIndex, valueToInitialiseWith:=FLAG_VALUE)

        Dim writeIndex As Long
        writeIndex = 0 ' Needs resetting each iteration, otherwise index will be incorrect or out of bounds

        Dim subtractionIndex As Long
        For subtractionIndex = LBound(arrayToSubtract) To UBound(arrayToSubtract)
            If arrayToSubtract(subtractionIndex) >= smallestSpacer Then
                Dim spacerIndex As Long
                For spacerIndex = 1 To countOfSpacers
                    writeIndex = writeIndex + 1
                    currentResults(writeIndex) = arrayToSubtract(subtractionIndex) - spacerSizes(spacerIndex)

                    If currentResults(writeIndex) = 0 Then
                        MaybeAddArrayToCollection someCollection:=outputCollection, someArray:=TranslateLoopStateToSpacerIndexes(writeIndex:=writeIndex, iterationIndex:=iterationIndex, countOfSpacers:=countOfSpacers)
                    End If
                Next spacerIndex
            Else
                writeIndex = writeIndex + countOfSpacers
            End If
        Next subtractionIndex

        If outputCollection.Count > 0 Then Exit For
    Next iterationIndex

    Set GetMinimumSpacerQuantities = outputCollection

End Function

Private Function TranslateLoopStateToSpacerIndexes(ByVal writeIndex As Long, ByVal iterationIndex As Long, ByVal countOfSpacers As Long) As Long()
    ' If you have the "writeIndex" for a particular iteration,
    ' you can figure out which spacer index (and therefore which
    ' spacer) the "writeIndex" represents via modular arithmetic.
    '
    ' Given the current iteration's "writeIndex", to figure out
    ' the previous iteration's "writeIndex":
    '       ROUNDUP( currentWriteIndex / countOfSpacers )
    '
    ' Do the above in a loop (with iterationIndex declining) and keep track of
    ' each spacerIndex encountered.

    Dim calculatedWriteIndex As Long
    calculatedWriteIndex = writeIndex ' Can't calculate first time around. We already know it.

    Dim outputArray() As Long
    ReDim outputArray(1 To countOfSpacers)

    Dim i As Long ' Needs better name, but also kind of irrelevant/unreferenced elsewhere.
    For i = iterationIndex To 1 Step -1
        Dim calculatedSpacerIndex As Long
        calculatedSpacerIndex = ((calculatedWriteIndex - 1) Mod countOfSpacers) + 1 ' -1 + 1 to return a 1-based index

        outputArray(calculatedSpacerIndex) = outputArray(calculatedSpacerIndex) + 1

        calculatedWriteIndex = Application.RoundUp(calculatedWriteIndex / countOfSpacers, 0)
    Next i

    TranslateLoopStateToSpacerIndexes = outputArray

End Function

Private Function GetInitialisedNumericArray(ByVal lengthOfArray As Long, ByVal valueToInitialiseWith As Long) As Long()
    ' lengthOfArray is expected to be 1-based.
    ' I chose Long as return type since spacer sizes in example only seem to include whole numbers.

    Dim outputArray() As Long
    ReDim outputArray(1 To lengthOfArray)

    Dim index As Long
    For index = LBound(outputArray) To UBound(outputArray)
        outputArray(index) = valueToInitialiseWith
    Next index

    GetInitialisedNumericArray = outputArray
End Function

Private Sub MaybeAddArrayToCollection(ByVal someCollection As Collection, ByRef someArray() As Long)

    Dim toJoin() As String
    ReDim toJoin(LBound(someArray) To UBound(someArray))

    Dim i As Long
    For i = LBound(someArray) To UBound(someArray)
        toJoin(i) = CStr(someArray(i))
    Next i

    Dim canonicalKey As String
    canonicalKey = Join$(toJoin, "|$%__|")

    On Error Resume Next
    someCollection.Add Item:=someArray, Key:=canonicalKey
    On Error GoTo 0

End Sub

对于您问题中的示例，我认为代码应该可以正常工作。但是，如果您的实际数据要大得多，请注意此代码将无法很好地扩展。此外，在以下情况下，您更有可能遇到内存问题：

垫片数量增加 目标和最小垫片尺寸之间的比率增加

---

由于这些因素也决定了搜索空间的大小。

Hi，欢迎使用堆栈溢出。这看起来可能是个家庭作业问题。如果是这样，请阅读，并张贴您的工作到目前为止。你的具体问题是什么？你试过什么？结果如何？发布这些信息确实让其他人更容易提供帮助。@Evan，谢谢。这不是家庭作业问题。这是我在工作中正在做的事情。我试过提供的几种计算器，但我遇到的问题是，所有的计算器都不允许使用重复的数字。例如，当我试图用上面列出的数字找到132毫米的组合时，我没有收到任何组合，因为它使用了44毫米黑色间隔三次。我想能够输入132和它的清单，我需要使用3个黑色间隔。这有用吗？谢谢你的回答！我要试试这个。我想我现在使用的最高数字应该是300左右。我要花钱吗

---

这是个错误吗？这很有效。不过我有个问题要问你。当有多个答案时，决定哪个选项的逻辑是什么？我这里的例子是64。出于我们的目的，我们最有可能使用两个绿色垫片。代码选择了一个白色和一个橙色。这里有什么可以做的吗？@BrianGundling，目前代码将返回它遇到的第一个解决方案。我认为，它遇到的第一个解决方案可能取决于垫片的原始排列顺序。要证明这一点，请尝试将绿色移动到白色上方，将目标输入为64。然后代码是否返回2绿色而不是1白色+1橙色。让我问你一个问题，为什么绿色2对你来说是一个更令人满意的解决方案？它是任意的还是有一些逻辑，例如最小数量的不同间隔？如果我把绿色放在白色上面，它会选择2个绿色。其逻辑是，我们更容易使用两个绿色间隔，而不是一个白色和一个橙色。我认为这很难用这个工具来决定。我再问你一个问题。是否可以将所有可能的组合填充到给定目标的表格中，以便我可以查看所有可能性的列表并选择最可行的？这将有助于在我们可能缺少某个特定尺寸的垫片的情况下。@BrianGundling我认为，如果您只需要最小数量的垫片的所有可能组合，而不是所有数量的垫片的所有可能组合，这是可能的。这应该只是一个将退出逻辑移动到最外层迭代循环的情况，可能在最内层循环中分配一个布尔标志/变量，以指示至少找到了一个解决方案，并且这将是最后一次迭代，并将所有解决方案存储在一个集合中。但我现在没有时间做这件事