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.
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.
VBA Code:
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
