Formula to select 6 Player Team with combined lowest rank score - /w Team salary cap of 50,000 or less

[hinsdale1]

Player	Salary	Rank	Picks
Jordan Spieth	12600	1.75
Jason Day	11500	4.2
Justin Rose	10900	5.25
Jim Furyk	8800	11.45
Bubba Watson	9900	15.2
Rickie Fowler	9800	19.9
Dustin Johnson	10700	22.3
Paul Casey	8700	23.05
Henrik Stenson	9600	24.1
Matt Kuchar	9300	24.4
Zach Johnson	8100	25.2
Brendan Steele	7100	25.25
Robert Streb	7900	27.95
Jason Bohn	6900	29.2
Danny Lee	7700	31.85
Webb Simpson	7900	32.25
Brooks Koepka	9700	35.85
Patrick Reed	8100	36.35
Rory Sabbatini	6400	36.6
Hideki Matsuyama	8500	38.5
Chad Campbell	6600	39.55
Russell Henley	7500	40.1
Brandt Snedeker	8600	42.05
David Lingmerth	7800	43.5
Jason Kokrak	6100	44
William McGirt	6400	51.15
Justin Thomas	7700	51.2
Ryan Moore	7600	52.05
Nick Watney	7000	52.35
Stewart Cink	6100	53.35
Bill Haas	8000	56.3
Will Wilcox	7200	57.05
Tony Finau	7300	57.1
Lee Westwood	7000	58.4
Pat Perez	6500	61.6
David Hearn	6300	61.7
Ryo Ishikawa	5800	62.25
Kevin Na	6900	64.3
Marc Leishman	7100	64.65
Jimmy Walker	7600	65.6
Charl Schwartzel	8200	65.6
Charles Howell III	6600	67
Jim Herman	6300	68.3
Matt Jones	6500	69
Harris English	6800	70.6
Scott Brown	6500	70.95
Boo Weekley	6300	72.5
Keegan Bradley	7500	72.5
Scott Piercy	6700	72.6
Russell Knox	6400	72.9
Daniel Summerhays	6200	75.5
J.B. Holmes	7300	76.3
Billy Horschel	7500	77.75
Luke Donald	7400	79.75
Vijay Singh	6200	80.8
Phil Mickelson	8300	81.15
George McNeill	6200	81.45
Carl Pettersson	7100	82.9
Jonas Blixt	6900	84.6
Greg Owen	6300	86.7
Davis Love III	6300	87.5
Ryan Palmer	6800	88.55
Shawn Stefani	6200	88.9
Adam Scott	8400	89.85
Kevin Kisner	6900	90.15
Mark Wilson	5700	91.25
Ian Poulter	7100	91.65
Colt Knost	5900	92.15
James Hahn	5900	93.5
Graham DeLaet	6800	93.8
Steven Bowditch	6600	95.75
Johnson Wagner	6000	95.9
Kevin Chappell	6700	96.1
Adam Hadwin	5800	98
Jason Dufner	6700	100.2
Alex Cejka	5600	102.9

<colgroup><col><col><col span="2"></colgroup><tbody>
</tbody>

Can excel Formula or vba script work to analyze table and place an "X" in Picks column next to the 6 Player Team which achieves the lowest possible total combined rank (adding their 6 rank scores together) WITH a Team salary Maximum of 50,000 or less?

Little out of my pay grade but would appreciate any help which points me in the right direction.

Thank you in advance to any MATH GENIUSES who are willing to assist!

 

[StephenCrump]

However, after playing around it looks like Rose, Furyk, Johnson, Steele, Streb and Bohn is your best 6 man team, 124.3 rank.

Rick

Agree! Or if you can spend $50,000 exactly, Rose, Furyk, Watson, Steele, Bohn and Sabbatini are ranked 122.95.

Brute force VBA takes only a couple of minutes with COMBIN(78,6) = 219m combinations.

Sub GetBestTeam()

    Dim vData As Variant
    Dim dRank As Double, dBestRank As Double
    Dim lTeam() As Long, lBestTeam() As Long, lCombinations As Long
    Dim lNoPlayers As Long, lSalary As Long, i As Long, j As Long, k As Long
    Const NO_CHOSEN = 6
    Const SALARY_CAP = 50000
    
    ReDim lTeam(1 To NO_CHOSEN)
    ReDim lBestTeam(1 To NO_CHOSEN)
    vData = Range("A2:C" & Range("A" & Rows.Count).End(xlUp).Row).Value
    lNoPlayers = UBound(vData)
    lCombinations = WorksheetFunction.Combin(lNoPlayers, NO_CHOSEN)
    dBestRank = 10000   'arbitrary big no
    
    For i = 1 To NO_CHOSEN
        lTeam(i) = i
    Next i
    
    For i = 2 To lCombinations
        lSalary = 0
        dRank = 0
        For j = NO_CHOSEN To 1 Step -1
            lTeam(j) = lTeam(j) + 1
            If lTeam(j) <= lNoPlayers - (NO_CHOSEN - j) Then Exit For
        Next j
        For k = j + 1 To NO_CHOSEN
            lTeam(k) = lTeam(k - 1) + 1
        Next k
        For k = 1 To NO_CHOSEN
            lSalary = lSalary + vData(lTeam(k), 2)
            dRank = dRank + vData(lTeam(k), 3)
        Next k
        If lSalary <= SALARY_CAP And dRank < dBestRank Then
            lBestTeam = lTeam
            dBestRank = dRank
        End If
    Next i
    
    Range("E1").Value = "Best Team"
    Range("E2").Resize(, NO_CHOSEN).Value = lBestTeam

End Sub

I wouldn't try brute force for many more than 78 players. But it wouldn't be hard to modify the code to think a little smarter.

Once you establish "by eye" that with a team of the better players you can get a ranking around 120 with a budget of $50,000, then we can start eliminating huge numbers of combinations of the lower ranked players. For example, if we sort the players in decreasing rank order so that Cejka is player # 1 on the team and Dufner is player #2, then for this one pairing we needn't test COMBIN(74,4)= ~1 million combinations because clearly all these combinations will have a ranking> 203.1.

 

[hinsdale1]

Nice work Stephen!.. just saw this post so haven't yet examined the code to see what you did...

But wanted to throw out a few thoughts.. if you limit the possible salary totals (for 6 players) to between 49,500 (cant see ever using a total salary less than that) and 50,000 - doesnt that dramatically reduce the number of possible combos?

Also not sure if you have already accounted for this.. but if place in the sequence doesnt matter.. wouldn't that also reduce combos? For example, there should be no distinction between team with Rose, Furyk, Watson, Steele, Bohn and Sabbatini and team with Furyk, Rose, Watson, Steele, Bohn and Sabbatini, and etc.. etc.

Anyway, not sure if these thoughts are helpful.. just wanted to quickly share before start trying to understand the code.. VERY COOL.. excited to see what can be done.

Once this is working, my next hope is to then be able to assign one, two, or three specific players to the team and then determine the best options to fill out the rest of the team (lowest combined rank at maximum of $50,000 team salary)

 

[hinsdale1]

Well, I limited 6 team salary total to combined 49,500 to 50,000 - not sure it made a big (if any) difference - still took my PC over 5 minutes to compute.. but..

IT WORKS!! and that is very cool. Thank you so very kindly, Mr. Crump (definitely owe u a beer).

Would it be difficult to now be able to assign one or two specific players to the team and then determine the best options to fill out the rest of the team (lowest combined rank at maximum of $50,000 team salary)? Of course, any help in this regard is greatly appreciated!

(I would also like to tweak see if can reduce the possible combo's/computing time.)

Welcome all input/advise from anyone willing to offer

 

[StephenCrump]

Let's get smarter ...

If we sort the players by salary, and sum in groups of 6, we can immediately see that we can get a ranking of <160 with a salary cap of $50,000. So I have set dBestRank = 160

Then let's sort the players in descending order by rank, ie Cejka first and Spieth last, and run the revised macro below.
This way, we only actually need to test around 240,000 combinations, which takes my machine less than a second.

Would it be difficult to now be able to assign one or two specific players to the team and then determine the best options to fill out the rest of the team?

The easiest way probably is to:

- Eliminate your two players from the list
- change Const NO_CHOSEN = 4
- Change Const SALARY_CAP = 40000 (or whatever 50000 less your two players' salaries comes to)

Sub GetBestTeam()

    Dim vData As Variant
    Dim dRank As Double, dBestRank As Double
    Dim lTeam() As Long, lBestTeam() As Long
    Dim lNoPlayers As Long, lSalary As Long, i As Long, j As Long
    Dim lIndexToChange As Long
    Dim bSuccess As Boolean
    Const NO_CHOSEN = 6
    Const SALARY_CAP = 50000
    
    ReDim lTeam(1 To NO_CHOSEN)
    ReDim lBestTeam(1 To NO_CHOSEN)
    vData = Range("A2:C" & Range("A" & Rows.Count).End(xlUp).Row).Value
    lNoPlayers = UBound(vData)
    dBestRank = 160   'based on quick inspection of data
    
    For i = 1 To NO_CHOSEN
        lTeam(i) = i
    Next i
    lTeam(NO_CHOSEN) = NO_CHOSEN - 1
    
    Do While lTeam(1) <= lNoPlayers - NO_CHOSEN
        lSalary = 0
        dRank = 0
        lIndexToChange = NO_CHOSEN
        
        'We can skip all combinations when salary cap or best rank (so far) is breached
        For i = 1 To NO_CHOSEN
            lSalary = lSalary + vData(lTeam(i), 2)
            dRank = dRank + vData(lTeam(i), 3)
            If lSalary > SALARY_CAP Or dRank >= dBestRank Then
                lIndexToChange = i
                Exit For
            End If
        Next i
        
        For i = lIndexToChange To 1 Step -1
            lTeam(i) = lTeam(i) + 1
            If lTeam(i) <= lNoPlayers - (NO_CHOSEN - i) Then Exit For
        Next i
        
        For j = i + 1 To NO_CHOSEN
            lTeam(j) = lTeam(j - 1) + 1
        Next j
        lSalary = 0
        dRank = 0
        For j = 1 To NO_CHOSEN
            lSalary = lSalary + vData(lTeam(j), 2)
            dRank = dRank + vData(lTeam(j), 3)
        Next j
        If lSalary <= SALARY_CAP And dRank < dBestRank Then
            lBestTeam = lTeam
            dBestRank = dRank
            bSuccess = True
        End If
        
        'Optional (and relatively slow): show combinations actually tested
        'lCount = lCount + 1
        'Range("L" & lCount).Resize(, NO_CHOSEN).Value = lTeam
    
    Loop
    
    Range("E1").Value = "Best Team"
    With Range("E2").Resize(, NO_CHOSEN)
        .ClearContents
        If bSuccess Then
            .Value = lBestTeam
        Else
            .Cells(1, 1).Value = "No teams!"
        End If
    End With
    
End Sub

 

[StephenCrump]

PS: The code doesn't allow for two or more combinations with the same combined rank. Not sure if that matters?

 

[hinsdale1]

Completely swag. Works like a charm. Can't thank you enough Stephen.. you ARE the man.

Last tweaks - 1) would there be a way to output the 2 or 3 best rosters (/w lowest combined rank scores) instead of just the best?

2) Also, sorry for being an idiot, but can't seem to tweak to output the best team vertically (in a column) instead of across a row? (I certainly can dig a little deeper - so feel free to ignore)

THANKS AGAIN!!! very impressed - and stoked to have workin

 

[StephenCrump]

Try this:

G1: NoInTeam
G2: NoOfPicks
G3: SalaryCap
G4: CutOffRank
F6: StartOutputHere

Excel 2010

	A	B	C	D	E	F	G	H	I
1	No	Player	Salary	Rank		No in team	6
2	1	Alex Cejka	$5,600	102.9		No of picks	4
3	2	Jason Dufner	$6,700	100.2		Salary cap	$50,000
4	3	Adam Hadwin	$5,800	98		CutOffRank	150
5	4	Kevin Chappell	$6,700	96.1
6	5	Johnson Wagner	$6,000	95.9		Best Teams
7	6	Steven Bowditch	$6,600	95.75		58	63	58	58
8	7	Graham DeLaet	$6,800	93.8		63	64	65	63
9	8	James Hahn	$5,900	93.5		65	65	66	65
10	9	Colt Knost	$5,900	92.15		72	66	69	71
11	10	Ian Poulter	$7,100	91.65		73	73	73	73
12	11	Mark Wilson	$5,700	91.25		74	74	74	74
13	12	Kevin Kisner	$6,900	90.15		122.95	124.30	126.80	127.65
14	13	Adam Scott	$8,400	89.85		$50,000	$49,700	$50,000	$49,900
15	14	Shawn Stefani	$6,200	88.9

<tbody>
</tbody>

1​

Workbook here: https://app.box.com/s/v2fdm8u3xsxhzf0h64bq5ttfqei7n63j

Code below:

Sub GetBestTeams()

    Dim vData As Variant
    Dim rngOutputCell As Range
    Dim dRank As Double, dBestRanks() As Double, dCutoffRank As Double
    Dim lTeam() As Long, lBestTeams() As Long, lBestSalaries() As Long
    Dim lNoPlayers As Long, lSalary As Long, i As Long, j As Long
    Dim lPlayerToChange As Long, lNoOfPicks As Long, lWorstPick As Long, lSuccesses As Long
    Dim lNoInTeam As Long, lSalaryCap As Long, lCutOffRank As Long
    
    lNoInTeam = Range("NoInTeam").Value
    lNoOfPicks = Range("NoOfPicks").Value
    lSalaryCap = Range("SalaryCap").Value
    lCutOffRank = Range("CutOffRank").Value
    Set rngOutputCell = Range("StartOutputHere")
    
    ReDim lTeam(1 To lNoInTeam)
    ReDim dBestRanks(1 To lNoOfPicks)
    ReDim lBestSalaries(1 To lNoOfPicks)
    ReDim lBestTeams(1 To lNoInTeam, 1 To lNoOfPicks)
    vData = Range("B2:D" & Range("B" & Rows.Count).End(xlUp).Row).Value
    lNoPlayers = UBound(vData)
    
    dCutoffRank = lCutOffRank
    lWorstPick = 1
    For i = 1 To lNoOfPicks
        dBestRanks(i) = lCutOffRank
    Next i
    For i = 1 To lNoInTeam
        lTeam(i) = i
    Next i
    lTeam(lNoInTeam) = lNoInTeam - 1
    
    'Loop through all possible combinations
    Do While lTeam(1) <= lNoPlayers - lNoInTeam
        lSalary = 0
        dRank = 0
        lPlayerToChange = lNoInTeam
        
        'If i'th player in combination causes breach of salary cap or cut-off rank, then
        'skip all sub-combinations and move to next player in i'th spot
        For i = 1 To lNoInTeam
            lSalary = lSalary + vData(lTeam(i), 2)
            dRank = dRank + vData(lTeam(i), 3)
            If lSalary > lSalaryCap Or dRank >= dCutoffRank Then
                lPlayerToChange = i
                Exit For
            End If
        Next i
        
        For i = lPlayerToChange To 1 Step -1
            lTeam(i) = lTeam(i) + 1
            If lTeam(i) <= lNoPlayers - (lNoInTeam - i) Then Exit For
        Next i
        
        For j = i + 1 To lNoInTeam
            lTeam(j) = lTeam(j - 1) + 1
        Next j
        
        'Test this combination
        lSalary = 0
        dRank = 0
        For i = 1 To lNoInTeam
            lSalary = lSalary + vData(lTeam(i), 2)
            dRank = dRank + vData(lTeam(i), 3)
        Next i
        If lSalary <= lSalaryCap And dRank < dCutoffRank Then
            'This combination is a best pick.  Re-rank best picks
            For i = 1 To lNoInTeam
                lBestTeams(i, lWorstPick) = lTeam(i)
                dBestRanks(lWorstPick) = dRank
                lBestSalaries(lWorstPick) = lSalary
            Next i
            dCutoffRank = 0
            For i = 1 To lNoOfPicks
                If dBestRanks(i) > dCutoffRank Then
                    lWorstPick = i
                    dCutoffRank = dBestRanks(i)
                End If
            Next i
        End If
    Loop
    
    'Results
    For i = 1 To lNoOfPicks
        If dBestRanks(i) < lCutOffRank Then lSuccesses = lSuccesses + 1
    Next i
    On Error Resume Next
    Range("MyResults").ClearContents
    On Error GoTo 0
    With rngOutputCell
        .Value = "Best Teams"
        If lSuccesses = 0 Then
            .Offset(1).Value = "No teams!"
        Else
            With .Offset(1).Resize(lNoInTeam + 2, lSuccesses)
                .Name = "MyResults"
                .NumberFormat = "0"
                .Value = lBestTeams
                .Rows(lNoInTeam + 1).Value = dBestRanks
                .Rows(lNoInTeam + 1).NumberFormat = "0.00"
                .Rows(lNoInTeam + 2).Value = lBestSalaries
                .Rows(lNoInTeam + 2).NumberFormat = "$#,##0"
                .Sort Key1:=.Rows(lNoInTeam + 1), Order1:=xlAscending, Orientation:=xlLeftToRight
            End With
        End If
    End With
    
End Sub

 

[hinsdale1]

Sorry for the delay in responding, I was completing the online form nominating Stephen Crump for the NOBEL PRIZE FOR COMPLETE AWESOMENESS.

Thanks, man - you're a stud.

 

[StephenCrump]

Thanks for the feedback ...

... but I'm happy to settle for the beer promised in Post #13.

 

[hinsdale1]

Hey Stephen - how hard would it be to modify your script to select the best Football teams?

Would work essentially the same as golf except have added column with positions.. the script would then need to select the best team of nine players/$50,000 salary cap - but must consist of one (1) QB, two (2) RBs , three (3) WRs, one (1) TE, one (1) FLEX (either WR,RB, or TE) and one (1) DST.

Is this something that might be accomplished without major rewrite?

I have attached your worksheet with new column for positions if helpful..

https://drive.google.com/file/d/0BxrTEtFSce2pZDU0eTVSdlMyY28/view?usp=sharing