[Hard] Store Combinations in an array

[Buzz1126]

Currently Working Program:
My program currently takes in a list of n players, and runs through each combination of m players (nCm), and pops out the combination with the most points, given the constraint that the cost must be less than the entered cost.

Normally this list could contain ~100 players but I want to keep it simple. For this example, we are choosing 3 players out of a possible 5 player pool and maximizing the total points (col. D) given that the total cost (col. C) is less than the max cost (cell C3).

Problem:
I would like to amend this program so that I can print the 5 combinations with the most total points (out of the 5C3 = 10 possible combinations).

Thank you in advance, and even help with the one of the steps to solve the problem would be use.

Sub Run()
  Dim cTot          As Currency   ' number of combos
  Dim aiC()         As Long       ' combination
  Dim cComb         As Currency   ' combination counter
  Dim nCombLow      As Long       ' low bits of combin counter

  Dim tBeg          As Date       ' start date/time
  Dim tET           As Single     ' elapsed time
  Dim tETT          As Double     ' estimated total time
  Dim f             As Single     ' start time (seconds past midnight)

  Dim n             As Long       ' number of players
  Dim m             As Long       ' number to choose

  Dim i             As Long       ' scratch index
  Dim aiCost()      As Long       ' player cost
  Dim adPts()       As Double     ' player points
  Dim aiPick()      As Long       ' pick = 1
  Dim iTotCost      As Long       ' cost for a given combo
  Dim iMaxCost      As Long       ' max cost allowed
  Dim dTotPts       As Double     ' points for a given combo
  Dim dMaxPts       As Double     ' max points so far
 
  'print array work ********************************************
  Dim ResultsTab, CalculatorTab As Worksheet
  Set CalculatorTab = ThisWorkbook.Sheets("Calculator")
  Set ResultsTab = ThisWorkbook.Sheets("Results")
  Dim PrintArr(1 To 10, 1 To 6)   As Variant       ' array to be printed, nCm x m
    
  '*************************************************************
  m = Range("ptrChoose").Value2
  ReDim aiC(1 To m)
  aiC(1) = -1

  iMaxCost = Range("ptrMaxCost").Value2

  Range("ptrMsg").ClearContents

  With Range("tbl") 'clears contents and sorts the tbl
    .Columns(4).ClearContents
    .Sort Key1:=.Columns(3), Order1:=xlDescending, Header:=xlNo
    n = .Rows.Count
    ReDim aiCost(1 To n) 'redims the cost and points arrays
    ReDim adPts(1 To n)

    For i = 1 To n 'adds values to the cost and points arrays
      aiCost(i) = .Cells(i, 2).Value2
      adPts(i) = .Cells(i, 3).Value2
    Next i
  End With

  cTot = WorksheetFunction.Combin(n, m)
 
  tBeg = Now
  f = Timer

'***************************************************************
'***************************************************************
' While Combo
'

  Do While bNextCombo(aiC, n) 'do while aic() is not the last combo
    cComb = cComb + 1 'combination counter
    nCombLow = nCombLow + 1 'low bits of combination counter
    
'****************************************************************
'   for the timer
'****************************************************************
    If (nCombLow And &HFFFFFF) = 0 Then
      nCombLow = 0

      tET = (Timer - f) / 86400
      If tET < 0 Then tET = tET + 1
      tETT = tET * cTot / cComb
      Range("ptrMsg").Value = "  ET = " & Format(tET, "hh:mm:ss") & _
                              "  ETT = " & Format(tETT, "hh:mm:ss") & _
                              "  ETA = " & Format(tBeg + tETT, "ddd mmm dd hh:mm:ss")
    End If

'****************************************************************

'**** EVALUATE COMBO *******

    iTotCost = 0 'cost for a given combo
    dTotPts = 0 'points for a given combo
    
    'evaluates the cost and total pts of a given combination
    For i = 1 To m 'm is number of players in the combo
      iTotCost = iTotCost + aiCost(aiC(i) + 1) 'cost for a combination
      dTotPts = dTotPts + adPts(aiC(i) + 1) 'total points for a combination
    Next i
    
    'decides if current combo is max combo
    If iTotCost <= iMaxCost Then
      If dTotPts > dMaxPts Then
        dMaxPts = dTotPts
        ReDim aiPick(1 To n, 1 To 1)
        For i = 1 To m
          aiPick(aiC(i) + 1, 1) = 1
        Next i
        Range("tbl").Columns(4).Value = aiPick
        Beep
        DoEvents
      End If
    End If
  Loop
 End Sub
 
'***********************************************************************

 Public Function bNextCombo(aiC() As Long, n As Long) As Boolean
  ' shg 2009-12
  '     2011-07 (modified to require aiC(1) < 0 to initialize)

  ' VBA only

  ' Sets aiC to the next combination of n choose m in lexical order
  ' Returns True unless the combination is the last, in which case
  ' it leaves aiC unmodified.

  ' If aiC(1) < 0, initializes aiC to the first combo:
  '                   {m-1,  m-2, ...,     1,   0}
  ' The last combo is {n-1,  n-2, ..., n-m+1, n-m}

  Dim m             As Long
  Dim i             As Long

  m = UBound(aiC)
  If n < m Then Exit Function

' aic(1) = -1, therefore aic(1) = 1 if m=3
  If aiC(1) < 0 Then    ' set initial combo
    i = 1
    aiC(1) = m - 2

  Else

    ' find rightmost incrementable index
    For i = m To 2 Step -1
      If aiC(i) < aiC(i - 1) - 1 Then Exit For
    Next i
  End If

  If i <> 1 Or aiC(1) < n - 1 Then
    ' increment that index, and set 'righter' indices descending to 0
    aiC(i) = aiC(i) + 1
    For i = i + 1 To m
      aiC(i) = m - i
    Next i

    bNextCombo = True
  End If
End Function

 

[J.Ty.]

Hi

Maybe I'm not understanding but I don't think you have to get all combinations.

For ex.,
- you have 100 players and want the top ten combinations 6 at a time in terms of added points

In this case I'd just use the 8 players with more points and calculate their combinations. Combin(8,6) = 28
You'll just have to get the top ten out of these 28 combinations.

Remark: if the players may have the same number of points you may want to include more than 10 combinations, all those with at least the number of points of the 6th biggest sum.

The OP wrote that he needs "the combination with the most points, given the constraint that the cost must be less than the entered cost." And this kills immediately the idea of using the most potent players, because they are probably most expensive, too.

 

[J.Ty.]

Indeed you need to solve the Knapsack Problem. You can read about it, and look if somebody has already published VBA code to solve it.

 

[Buzz1126]

Indeed you need to solve the Knapsack Problem. You can read about it, and look if somebody has already published VBA code to solve it.

Perfect, thank you. I did this problem back in school. I'm going to give it a go over the next day or two. Might pop back in here with a question if I get to it. I'll also mark as solved if i figure it out.

I guess I'm wrong assuming my code evaluates all possible combinations? It has to be using a heuristic as well.

Thank you to all responses as well.

 

[pgc01]

The OP wrote that he needs "the combination with the most points, given the constraint that the cost must be less than the entered cost." And this kills immediately the idea of using the most potent players, because they are probably most expensive, too.

Thank you J.Ty.
Should read with more attention.

 

[J.Ty.]

I guess I'm wrong assuming my code evaluates all possible combinations? It has to be using a heuristic as well.

You initial code intended to consider all combinations (or at least this is what I understood).

In the case of the Knapsack Problem you can produce an exact algorithm whose running time is proportional to
(price limit)*(numer of players)*(number of choices to be made)
Indeed, it is based on a clever computation method called dynamic programming, which is based on systematic filling an array of the above dimensions.

Of course, there are heuristic algorithms, too, but the above one is probably totally acceptable, because the size of your problem is not that high.

J.Ty.