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

[hinsdale1]

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


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
Player	No in team
Alex Cejka	No of picks
Jason Dufner	Salary cap
Adam Hadwin	CutOffRank
Kevin Chappell
Johnson Wagner	Best Teams
Steven Bowditch
Graham DeLaet
James Hahn
Colt Knost
Ian Poulter
Mark Wilson
Kevin Kisner
Adam Scott
Shawn Stefani

<tbody>
[TD="align: center"]1[/TD]
[TD="align: center"]No[/TD]

[TD="align: right"]Salary[/TD]
[TD="align: right"]Rank[/TD]
[TD="align: right"][/TD]

[TD="align: right"]6[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]2[/TD]
[TD="align: center"]1[/TD]

[TD="align: right"]$5,600[/TD]
[TD="align: right"]102.9[/TD]
[TD="align: right"][/TD]

[TD="align: right"]4[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]3[/TD]
[TD="align: center"]2[/TD]

[TD="align: right"]$6,700[/TD]
[TD="align: right"]100.2[/TD]
[TD="align: right"][/TD]

[TD="align: right"]$50,000[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]4[/TD]
[TD="align: center"]3[/TD]

[TD="align: right"]$5,800[/TD]
[TD="align: right"]98[/TD]
[TD="align: right"][/TD]

[TD="align: right"]150[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]5[/TD]
[TD="align: center"]4[/TD]

[TD="align: right"]$6,700[/TD]
[TD="align: right"]96.1[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]6[/TD]
[TD="align: center"]5[/TD]

[TD="align: right"]$6,000[/TD]
[TD="align: right"]95.9[/TD]
[TD="align: right"][/TD]

[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

[TD="align: center"]7[/TD]
[TD="align: center"]6[/TD]

[TD="align: right"]$6,600[/TD]
[TD="align: right"]95.75[/TD]
[TD="align: right"][/TD]
[TD="align: right"]58[/TD]
[TD="align: right"]63[/TD]
[TD="align: right"]58[/TD]
[TD="align: right"]58[/TD]

[TD="align: center"]8[/TD]
[TD="align: center"]7[/TD]

[TD="align: right"]$6,800[/TD]
[TD="align: right"]93.8[/TD]
[TD="align: right"][/TD]
[TD="align: right"]63[/TD]
[TD="align: right"]64[/TD]
[TD="align: right"]65[/TD]
[TD="align: right"]63[/TD]

[TD="align: center"]9[/TD]
[TD="align: center"]8[/TD]

[TD="align: right"]$5,900[/TD]
[TD="align: right"]93.5[/TD]
[TD="align: right"][/TD]
[TD="align: right"]65[/TD]
[TD="align: right"]65[/TD]
[TD="align: right"]66[/TD]
[TD="align: right"]65[/TD]

[TD="align: center"]10[/TD]
[TD="align: center"]9[/TD]

[TD="align: right"]$5,900[/TD]
[TD="align: right"]92.15[/TD]
[TD="align: right"][/TD]
[TD="align: right"]72[/TD]
[TD="align: right"]66[/TD]
[TD="align: right"]69[/TD]
[TD="align: right"]71[/TD]

[TD="align: center"]11[/TD]
[TD="align: center"]10[/TD]

[TD="align: right"]$7,100[/TD]
[TD="align: right"]91.65[/TD]
[TD="align: right"][/TD]
[TD="align: right"]73[/TD]
[TD="align: right"]73[/TD]
[TD="align: right"]73[/TD]
[TD="align: right"]73[/TD]

[TD="align: center"]12[/TD]
[TD="align: center"]11[/TD]

[TD="align: right"]$5,700[/TD]
[TD="align: right"]91.25[/TD]
[TD="align: right"][/TD]
[TD="align: right"]74[/TD]
[TD="align: right"]74[/TD]
[TD="align: right"]74[/TD]
[TD="align: right"]74[/TD]

[TD="align: center"]13[/TD]
[TD="align: center"]12[/TD]

[TD="align: right"]$6,900[/TD]
[TD="align: right"]90.15[/TD]
[TD="align: right"][/TD]
[TD="align: right"]122.95[/TD]
[TD="align: right"]124.30[/TD]
[TD="align: right"]126.80[/TD]
[TD="align: right"]127.65[/TD]

[TD="align: center"]14[/TD]
[TD="align: center"]13[/TD]

[TD="align: right"]$8,400[/TD]
[TD="align: right"]89.85[/TD]
[TD="align: right"][/TD]
[TD="align: right"]$50,000[/TD]
[TD="align: right"]$49,700[/TD]
[TD="align: right"]$50,000[/TD]
[TD="align: right"]$49,900[/TD]

[TD="align: center"]15[/TD]
[TD="align: center"]14[/TD]

[TD="align: right"]$6,200[/TD]
[TD="align: right"]88.9[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]

</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