Highest possible sum

Question

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.

Answer 1

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

Answer 2

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