最高可能的总和
我在A列中有一个项目列表，每个项目在后续列中都有10个不同的值。我需要创建一个公式（或者最可能是多个公式），它将返回10个值的最高总和（每列一个），并限制每个项目最多可以使用一次。我还需要一个使用这些项目的订单。我试图通过几个步骤来完成它：
第1步： 检查B列中的最高值。
第2步： 检查C列中的最高值。
第3步： 如果这是相同的项目，那么找到列B和C的第二个最高值，并检查哪个总和更高（B的第1个和C的第二个或其他方式）。
然而，在极少数情况下，此算法会提供不正确的输出，并且公式会呈指数级增长，因为我需要为每列添加10个不同值的比较。如果我有一天试图扩大价值的数量，那将是非常麻烦的。如果您看到更好的解决方案，请告诉我。我不介意是否需要VBA。
2 个答案:
答案 0 :(得分：3)
如果您需要查看所有组合并提出最佳解决方案，那么这看起来像Knapsack problem或另一个NP完全问题的版本：
如果有人对上述笑话的解决方案感兴趣，可以用6个嵌套循环实现，如果我们认为解决方案由最大6×6个元素组成（例如，如果有1美分的甜点，那么无法达到1505 x 1 cent的明显解决方案：
Option Explicit
Sub TestMe()
Dim myArr As Variant
Dim myLoop As Variant
Dim targetValue As Long
Dim currentSum As Long
myArr = Array(215, 275, 335, 355, 420, 580)
targetValue = 1505
Dim cnt0&, cnt1&, cnt2&, cnt3&, cnt4&, cnt5&, cnt6&
Dim cnt As Long
For cnt0 = 0 To 5
For cnt1 = 0 To 5
For cnt2 = 0 To 5
For cnt3 = 0 To 5
For cnt4 = 0 To 5
For cnt5 = 0 To 5
currentSum = 0
Dim printableArray As Variant
printableArray = Array(cnt0, cnt1, cnt2, cnt3, cnt4, cnt5)
For cnt = LBound(myArr) To UBound(myArr)
IncrementSum printableArray(cnt), myArr(cnt), currentSum
Next cnt
If currentSum = targetValue Then
printValuesOfArray printableArray, myArr
End If
Next: Next: Next: Next: Next: Next
End Sub
Public Sub printValuesOfArray(myArr As Variant, initialArr As Variant)
Dim cnt As Long
Dim printVal As String
For cnt = LBound(myArr) To UBound(myArr)
If myArr(cnt) Then
printVal = printVal & myArr(cnt) & " * " & initialArr(cnt) & vbCrLf
End If
Next cnt
Debug.Print printVal
End Sub
Public Sub IncrementSum(ByVal multiplicator As Long, _
ByVal arrVal As Long, ByRef currentSum As Long)
currentSum = currentSum + arrVal * multiplicator
End Sub
因此唯一的解决方案是：
1 * 215
2 * 355
1 * 580
如果您已经学习了一个多学期的算法并且某种程度上讨厌嵌套循环，那么上面的代码可以用递归来编写：
Option Explicit
Sub Main()
Dim posArr As Variant
Dim iniArr As Variant
Dim tryArr As Variant
Dim cnt As Long
Dim targetVal As Long: targetVal = 1505
iniArr = Array(215, 275, 335, 355, 420, 580)
ReDim posArr(UBound(iniArr))
ReDim tryArr(UBound(iniArr))
For cnt = LBound(posArr) To UBound(posArr)
posArr(cnt) = cnt
Next cnt
EmbeddedLoops 0, posArr, tryArr, iniArr, targetVal
End Sub
Function EmbeddedLoops(index As Long, posArr As Variant, tryArr As Variant, _
iniArr As Variant, targetVal As Long)
Dim myUnit As Variant
Dim cnt As Long
If index >= UBound(posArr) + 1 Then
If CheckSum(tryArr, iniArr, targetVal) Then
For cnt = LBound(tryArr) To UBound(tryArr)
If tryArr(cnt) Then Debug.Print tryArr(cnt) & " x " & iniArr(cnt)
Next cnt
End If
Else
For Each myUnit In posArr
tryArr(index) = myUnit
EmbeddedLoops index + 1, posArr, tryArr, iniArr, targetVal
Next myUnit
End If
End Function
Public Function CheckSum(posArr, iniArr, targetVal) As Boolean
Dim cnt As Long
Dim compareVal As Long
For cnt = LBound(posArr) To UBound(posArr)
compareVal = posArr(cnt) * iniArr(cnt) + compareVal
Next cnt
CheckSum = CBool(compareVal = targetVal)
End Function
答案 1 :(得分：1)
以下VBA宏假定项目名称位于Column A，值位于Columns B to K，Row 1是标题，值为Long （即没有小数点）
这是一种低效的强力方法。对于10个项目，计算大约需要2分钟。对于11个项目，大约需要7.5分钟等等 - 因为增长将呈指数级增长，将想要在运行之前削减可能的答案。 （例如，每列的项目将取自该列的前10个值 - 因此，您可以删除任何列中未出现在前10位的项目）
Option Explicit
Sub VeryLongBruteForceMethod()
Dim Screen As Boolean, Calc As XlCalculation, Mouse As XlMousePointer
Mouse = Application.Cursor
Application.Cursor = xlDefault
Screen = Application.ScreenUpdating
Calc = Application.Calculation
Application.Cursor = xlWait
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Row / Value for each column
Dim MaxItems(0 To 9, 0 To 1) As Long, lMaxVal As Long
Dim TestItems(0 To 9, 0 To 1) As Long, lTestVal As Long
Dim lMaxRow As Long, lTestRow As Long, bTest As Boolean
Dim lCol0 As Long, lCol1 As Long, lCol2 As Long, lCol3 As Long, lCol4 As Long
Dim lCol5 As Long, lCol6 As Long, lCol7 As Long, lCol8 As Long, lCol9 As Long
Dim wsTarget As Worksheet
Set wsTarget = ThisWorkbook.Worksheets(1) 'First sheet in Workbook
lMaxRow = wsTarget.Cells(wsTarget.Rows.Count, 1).End(xlUp).Row 'Get Row for last item
lMaxVal = 0
For lCol0 = 2 To lMaxRow 'Assumes Row1 is a header
TestItems(0, 0) = lCol0 'Store row
TestItems(0, 1) = wsTarget.Cells(lCol0, 2).Value 'Store value
For lCol1 = 2 To lMaxRow 'Assumes Row1 is a header
bTest = True
If lCol1 = lCol0 Then bTest = False 'Row already used in this permutation
If bTest Then
TestItems(1, 0) = lCol1 'Store row
TestItems(1, 1) = wsTarget.Cells(lCol1, 3).Value 'Store value
For lCol2 = 2 To lMaxRow 'Assumes Row1 is a header
bTest = True
For lTestRow = 0 To 1
If TestItems(lTestRow, 0) = lCol2 Then
bTest = False 'Row already used in this permutation
Exit For '1 failure is enough
End If
Next lTestRow
If bTest Then
TestItems(2, 0) = lCol2 'Store row
TestItems(2, 1) = wsTarget.Cells(lCol2, 4).Value 'Store value
For lCol3 = 2 To lMaxRow 'Assumes Row1 is a header
bTest = True
For lTestRow = 0 To 2
If TestItems(lTestRow, 0) = lCol3 Then
bTest = False 'Row already used in this permutation
Exit For '1 failure is enough
End If
Next lTestRow
If bTest Then
TestItems(3, 0) = lCol3 'Store row
TestItems(3, 1) = wsTarget.Cells(lCol3, 5).Value 'Store value
For lCol4 = 2 To lMaxRow 'Assumes Row1 is a header
bTest = True
For lTestRow = 0 To 3
If TestItems(lTestRow, 0) = lCol4 Then
bTest = False 'Row already used in this permutation
Exit For '1 failure is enough
End If
Next lTestRow
If bTest Then
TestItems(4, 0) = lCol4 'Store row
TestItems(4, 1) = wsTarget.Cells(lCol4, 6).Value 'Store value
For lCol5 = 2 To lMaxRow 'Assumes Row1 is a header
bTest = True
For lTestRow = 0 To 4
If TestItems(lTestRow, 0) = lCol5 Then
bTest = False 'Row already used in this permutation
Exit For '1 failure is enough
End If
Next lTestRow
If bTest Then
TestItems(5, 0) = lCol5 'Store row
TestItems(5, 1) = wsTarget.Cells(lCol5, 7).Value 'Store value
For lCol6 = 2 To lMaxRow 'Assumes Row1 is a header
bTest = True
For lTestRow = 0 To 5
If TestItems(lTestRow, 0) = lCol6 Then
bTest = False 'Row already used in this permutation
Exit For '1 failure is enough
End If
Next lTestRow
If bTest Then
TestItems(6, 0) = lCol6 'Store row
TestItems(6, 1) = wsTarget.Cells(lCol6, 8).Value 'Store value
For lCol7 = 2 To lMaxRow 'Assumes Row1 is a header
bTest = True
For lTestRow = 0 To 6
If TestItems(lTestRow, 0) = lCol7 Then
bTest = False 'Row already used in this permutation
Exit For '1 failure is enough
End If
Next lTestRow
If bTest Then
TestItems(7, 0) = lCol7 'Store row
TestItems(7, 1) = wsTarget.Cells(lCol7, 9).Value 'Store value
For lCol8 = 2 To lMaxRow 'Assumes Row1 is a header
bTest = True
For lTestRow = 0 To 7
If TestItems(lTestRow, 0) = lCol8 Then
bTest = False 'Row already used in this permutation
Exit For '1 failure is enough
End If
Next lTestRow
If bTest Then
TestItems(8, 0) = lCol8 'Store row
TestItems(8, 1) = wsTarget.Cells(lCol8, 10).Value 'Store value
For lCol9 = 2 To lMaxRow 'Assumes Row1 is a header
bTest = True
For lTestRow = 0 To 8
If TestItems(lTestRow, 0) = lCol9 Then
bTest = False 'Row already used in this permutation
Exit For '1 failure is enough
End If
Next lTestRow
If bTest Then
TestItems(9, 0) = lCol9 'Store row
TestItems(9, 1) = wsTarget.Cells(lCol9, 11).Value 'Store value
lTestVal = 0
'Application.StatusBar = lCol0 & "|" & lCol1 & "|" & lCol2 & "|" & lCol3 & "|" & lCol4 & "|" & lCol5 & "|" & lCol6 & "|" & lCol7 & "|" & lCol8 & "|" & lCol9
For lTestRow = 0 To 9 'Total up our Value
lTestVal = lTestVal + TestItems(lTestRow, 1)
Next lTestRow
If lTestVal > lMaxVal Then 'Compare to current Max
For lTestRow = 0 To 9 'If more, replace with new Max
MaxItems(lTestRow, 0) = TestItems(lTestRow, 0)
MaxItems(lTestRow, 1) = TestItems(lTestRow, 1)
Next lTestRow
lMaxVal = lTestVal
End If
End If
Next lCol9
End If
Next lCol8
End If
Next lCol7
End If
DoEvents ' Try not to let Excel crash on us!
Next lCol6
End If
Next lCol5
End If
Next lCol4
End If
Next lCol3
End If
Next lCol2
End If
Next lCol1
Next lCol0
'Output to a message box:
'Column 1: ItemName01 | Value01
' ...
'Column 10: ItemName10 | Value10
'Total Value | TotalValue
Dim sOutput As String
sOutput = ""
For lTestRow = 0 To 9
sOutput = sOutput & "Column " & (lTestRow + 1) & ": " & wsTarget.Cells(MaxItems(lTestRow, 0), 1).Value & " | " & MaxItems(lTestRow, 1) & vbCrLf
Next lTestRow
sOutput = sOutput & "Total Value | " & lMaxVal
MsgBox sOutput
Erase TestItems
Erase MaxItems
Application.StatusBar = False
Application.Cursor = Mouse
Application.Calculation = Calc
Application.ScreenUpdating = Screen
End Sub
相关问题
最新问题
- 我写了这段代码，但我无法理解我的错误
- 我无法从一个代码实例的列表中删除 None 值，但我可以在另一个实例中。为什么它适用于一个细分市场而不适用于另一个细分市场？
- 是否有可能使 loadstring 不可能等于打印？卢阿
- java中的random.expovariate()
- Appscript 通过会议在 Google 日历中发送电子邮件和创建活动
- 为什么我的 Onclick 箭头功能在 React 中不起作用？
- 在此代码中是否有使用“this”的替代方法？
- 在 SQL Server 和 PostgreSQL 上查询，我如何从第一个表获得第二个表的可视化
- 每千个数字得到
- 更新了城市边界 KML 文件的来源？