Reputation: 89
Highest possible sum
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:
Step 1: Check the highest value in column B.
Step 2: Check the highest value in column 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).
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.
Upvotes: 0
Views: 167
Answers (2)
Reputation: 43595
If you need to take a look at all combinations and come up with the best solution, then this looks like a version of the Knapsack problem or another NP-complete problem:
Image: https://xkcd.com/287/
If someone is interested in the solution of the joke above, it can be achieved with 6 nested loops, if we consider that the solution consists of maximal 6×6 elements (e.g., if there was a dessert for 1 cent, then the obvious solution for 1505 x 1 cent will not be reached:
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
Thus the only solution is:
1 * 215
2 * 355
1 * 580
And if you have studied more than one semester of Algorithms and somehow you hate nested loops, then the above code can be written with recursion:
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
Upvotes: 3
Reputation: 7951
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)
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
Upvotes: 1
Related Questions
- How can I group a column of totals into a set where each set has a maximum
- How to find highest sum of multiple items in Excel
- variable with the highest number of value
- 2D - Finding largest sum of different combination in Excel
- Highest Sum Value
- Excel: Sum of largest numbers
- Find the maximum value
- Is there a workaround when hitting the maximum summands in =sum in an Excel formula?
- how to find the max 'n' values for data based on SUM of values?
- Max value in Worksheet