最高金额 [英] Highest possible sum
问题描述
我在A列中有一个项目列表，并且每个项目在后续列中都有10个不同的值.我需要创建一个公式(或者最有可能超过一个公式)，该公式将返回最大可能的10个值的总和(每个列中的一个)，并限制每个项目最多只能使用一次.我还需要使用这些物品的订单.我正试图通过几个步骤做到这一点:
I have a list of items in column A and each of this items has 10 different values in subsequent columns. I need to create a formula (or most probably more than one formula) that would return the highest possible sum of 10 values (one from each column) with a restriction that each item can be used one time at most. I would also need an order in which those items were used. I was trying to do it in a few steps:
第1步:检查B列中的最大值.
Step 1: Check the highest value in column B.
第2步:检查C列中的最大值.
Step 2: Check the highest value in column C.
第3步:如果这是同一项目，则在B和C列中找到第二高的值，并检查哪个总和更高(B的第一位和C的第二位或其他方式).
Step 3: If this is the same item then find the second highest value for columns B and C and check which sum is higher (1st of B and second of C or other way around).
但是，在极少数情况下，此算法会给出错误的输出，并且由于我需要为每列添加10个不同值的比较，因此该公式呈指数增长.如果有一天我试图扩展值的数量，那将很麻烦.如果您看到更好的解决方案，请告诉我.我不介意是否需要VBA.
This algorithm however in rare cases gives incorrect output and the formula grows exponentially as I need to add comparison for 10 different values for each column. It would be quite bothersome if I tried to expand the number of values someday. If you see a better solution please let me know. I wouldn't mind if that would need VBA.
推荐答案
下面的VBA宏假定项目名称在 A列中，值在 B到K列，则 Row 1 是标题，并且值是 Long (即无小数点)
The following VBA macro assumes that the Item Name is in Column A, the Values are in Columns B to K, that Row 1 is a header, and that the Values are Long (i.e. no Decimal points)
这是一种效率低下的蛮力方法.对于10个项目，大约需要2分钟才能计算出来.对于11个项目，大约需要7.5分钟，以此类推-由于增长将成倍增长，因此您将希望在运行它之前先减少可能的答案.(例如，每列的项目将从该列的前10个值中提取-因此，您可以删除任何列的前10个未出现的项目)
This is an inefficient brute-force method. For 10 items, it takes about 2 minutes to calculate. For 11 items, it takes about 7.5 minutes, etc - since growth will be exponential, you will want to pare down the possible answers before you run it. (e.g. the Item for each column will be taken from the top 10 Values for that column - so, you can delete any item that doesn't appear in the top 10 for any column)
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
这篇关于最高金额的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
