How to Create Randomized Teams for a Golf Scramble Based on Player Ranking.

[deltarazorback]

My excel knowledge is limited so bare with me. Essentially I am part of a weekly golf group that meets up once a week to participate in a scramble. The making of teams usually turns into some kind of debacle so i suggested we just use excel to randomly generate the teams that way nobody can be held accountable. Essentially I have a list of names player ranking 1, 2, 3, 4, 5. Each week we are unsure exactly who will show up (out of about 35 potential players) then make the teams based on who is there. I would love the option to just "check mark" players as they show up, hit a"Create" button and excel spits out groups of 4 or 5 (with as close to 1, 2, 3, 4, 5 on each team as possible). I could see this being done by fitting the players into columns based on their ranking (all the 1's in one column, 2's in the next, ect.), then pulling one from each column for each team or figure out how to tell excel to pull random names from the entire list and add up their rankings to make the total "ranking score" as equal as possible for a pre-determined number of teams. It is unlikely there will be equal number of 1's, 2's, ect. any given week. Which of these methods would you recommend I get to work on or any other advice would be appreciated.

Thanks

[Logit]

.
Here is one way to create the teams :

Sub MakeTeams()
Dim Players(200, 3), TeamSize(10) As Integer, TeamRating(10) As Double
Dim i As Integer, r As Integer, j As Integer, c As Integer, ctr As Integer
Dim Numplayers As Integer, NumTeams As Integer, trials As Integer
Dim t As Integer, tc As Integer, MaxRating As Double, MinRating As Double
Dim MyText As String
' Written by Eric W.  1/9/2016

' How many teams?
    NumTeams = Range("D2").Value
    If NumTeams > 10 Or NumTeams < 2 Or Int(NumTeams) <> NumTeams Then
        MsgBox "The number of teams must be an integer from 2-10."
        Exit Sub
    End If
    
' Read all the players and ratings
    r = 2
    Erase Players, TeamSize, TeamRating
    
    While Cells(r, "A") <> ""
        If r > 201 Then
            MsgBox "The number of players must be under 200."
            Exit Sub
        End If
        Players(r - 1, 1) = Cells(r, "A")
        Players(r - 1, 2) = Cells(r, "B")
        r = r + 1
    Wend
    Numplayers = r - 2
    
' Figure out the team sizes
    For r = 1 To NumTeams
        TeamSize(r) = Int(Numplayers / NumTeams) + IIf(r <= (Numplayers Mod NumTeams), 1, 0)
    Next r
    
' Make random teams
    trials = 0
    While trials < 100
        Call Shuffle(Players, Numplayers)
        
' Figure out the team ratings
        t = 1
        tc = 1
        Erase TeamRating
        MaxRating = -1
        MinRating = 11
        For i = 1 To Numplayers
            TeamRating(t) = TeamRating(t) + Players(i, 2)
            tc = tc + 1
            If tc > TeamSize(t) Then
                TeamRating(t) = TeamRating(t) / TeamSize(t)
                If TeamRating(t) > MaxRating Then MaxRating = TeamRating(t)
                If TeamRating(t) < MinRating Then MinRating = TeamRating(t)
                t = t + 1
                tc = 1
            End If
        Next i

' Max team rating - min team rating within the limit?
        If MaxRating - MinRating <= Cells(2, "F") Then GoTo PrintTeams
        
' Nope, try again
        trials = trials + 1
    Wend
    
    MyText = "Unable to find a valid set of teams in 100 tries." & Chr(10) & Chr(10)
    MyText = MyText & "You may try again using a higher MaxRatingDiff or" & Chr(10)
    MyText = MyText & "add more players to list or decrease the NumTeams"
    MsgBox MyText
    Exit Sub
    
' Print the teams
PrintTeams:
    Range("J1:AP20").ClearContents
    ctr = 1
    For i = 1 To NumTeams
        c = i * 3 + 6
        Cells(1, c) = "Team " & Chr(64 + i)
        For j = 1 To TeamSize(i)
            Cells(j + 1, c) = Players(ctr, 1)
            Cells(j + 1, c + 1) = Players(ctr, 2)
            ctr = ctr + 1
        Next j
        Cells(TeamSize(1) + 3, c + 1) = TeamRating(i)
    Next i
    
End Sub
' This team will randomly shuffle the players
' (It's really a bad sort, but with under 100 players, it should be good enough.)
Sub Shuffle(ByRef Players, ByVal Numplayers)
Dim i As Integer
Dim j As Integer
Dim a, b, c
' Assign a random number to each player
    For i = 1 To Numplayers
        Players(i, 3) = Rnd()
    Next i
    
' Now sort by the random numbers
    For i = 1 To Numplayers
        For j = 1 To Numplayers
            If Players(i, 3) > Players(j, 3) Then
                a = Players(i, 1)
                b = Players(i, 2)
                c = Players(i, 3)
                Players(i, 1) = Players(j, 1)
                Players(i, 2) = Players(j, 2)
                Players(i, 3) = Players(j, 3)
                Players(j, 1) = a
                Players(j, 2) = b
                Players(j, 3) = c
            End If
        Next j
    Next i
    
End Sub

Col I1 to I20 and everything to the right is used for teams creation. Nothing should be written in that area as it will be erased when creating the teams.

I don't know about the check marks but this project works by copying and pasting names to the list.

[deltarazorback]

This is exactly what I was looking for, manually inputing the players that show up that day is not a big deal so this should work. Thank you

[Stayzee]

Logit, Can you take this one step further and figure into your equation the fact that some couples want to play together? Thanks for any additional help. This is so close to what I have been looking for. Just need that extra step. Thanks!

[CRJ42]

Do you have any suggestions for accomplishing the above with non VBA code?

[Logit]

You are welcome.

[deltarazorback]

Is there a way to assign the "MaxRatingDiff" to the lowest possible number that would return results? (in turn making the team averages as close as possible to each other)

[Logit]

Always use "1". That's as close as they can get to one another in rankings.

[deltarazorback]

I am curious as to why "1" will yield the best results. For example, when I run a sample with "1" the best team averages a ranking of 2.4 and the worst team a 3.2. When i change the MaxDifferential to "0.5" the worst team average rating is 3.0 and the best is 2.6. The second method yields teams with closer average ratings and thus is a more equal team. What am I missing?

[leelnich]

Hi all- If you have some teams with 4 players, some with 5, how is that handled? Do you want a higher average ranking on smaller teams to make up the difference? Or do you have some scoring mechanism to even the results?

[Logit]

.
I ran several examples using 3, 4 and 5 Teams.

Each Team number was run with 1 - 6 MaxRatingDiff


Here is the result:

# TEAMS	MAXRATE DIFF
5	1		1
5	2		1.5
5	3		1.5
5	4		2.75
5	5		2.75
5	6		4.25
4	1		0.7
4	2		1.73333
4	3		6.3333
4	4		3.8
4	5		4.16667
4	6		2.6
3	1		2.85744
3	2		0.429
3	3		0.714286
3	4		3.428571
3	5		3
3	6		0.714286

First of all, if you run the same simulations, your results will differ because the program is randomly choosing the team members. They are different each time, hence the MaxRatingDiff will be slightly different as well.

However, you can see that using the lowest MaxRatingDiff number usually produces the closest matched teams.


Hope that makes sense ?

[Logit]

.
One of the moderators will eventually point this out to you .... You should not (what is referred to as 'high jacking') high jack someone else's thread. You can refer to it in your own thread, using it as an example or reference to what you are seeking.
Post your own thread with a descriptive basis.

Now .. to your question ... I would take the easy way out (sorry, not too enthusiastic in retirement). I'd average the two people's rating together.
Then I'd list them together in the Players Name column.

Amy = 1
Cindy = 2

Average is 1.5

List them in Players Column as Amy & Cindy with rating of 1.5

Then proceed as usual with the teams.

[Logit]

.
One of the moderators will eventually point this out to you .... You should not (what is referred to as 'high jacking') high jack someone else's thread. You can refer to it in your own thread, using it as an example or reference to what you are seeking.
Post your own thread with a descriptive basis.

[CRJ42]

Sorry about that, I was looking for possible solution(s) to my original post - I ran across your earlier post and found it interesting, however, I am looking for a "non VBA" solution...there is no attempt on my part to "high jack" someone's thread.

[alansidman]

Administrative Note:

Welcome to the forum.

We are happy to help, however whilst you feel your request is similar to this thread, experience has shown that things soon get confusing when answers refer to particular cells/ranges/sheets which are unique to your post and not relevant to the original.

Please see Forum Rule #4 about hijacking and start a new thread for your query.

If you are not familiar with how to start a new thread see the FAQ: How to start a new thread