VBA to randomly select teams from list of players

[EinarG]

Excel 2013, Win 7 Pro

Starting with column A (Player Names) and column B (Player rating - value between 0-10), I need a macro to divide the players into either 2, 4 or 6 teams randomly. Column A would have less than 100 names. Teams are named TeamA, TeamB...TeamF. TeamA competes against TeamB, etc.

I have two parameters: NumTeams = Number of teams (2,4 or 6) and MaxRatingDiff = Maximum allowed Team Rating Difference between competing teams

Each team has a rating defined as the average of the ratings of the players on that team.

Competing teams either have the same number of players or one of them (B, D or F) can have an extra player when there is an odd number of players. Example: 23 players, 4 teams would result in player counts of TeamA=6, TeamB=6, TeamC=5, TeamD=6.

I need a VBA Macro to generate approximately even strength teams with the constraint that the difference in team rating between any two competing teams does not exceed MaxRatingDiff. Alternatively, a macro that can be re-run manually (using a command button for example) by the user until he/she is satisfied with the teams. The generated teams should be in columns (Name and Rating) sorted descending by the player rating.

Thanks for help on this or any portion of it!

 

[Max1616]

This will randomly sort your players onto teams (column C). Based on NumTeams which I assigned to "Z1" within the Macro. I'll work on Monday to get this to accommodate the MaxRatingDiff. I'm not sure how I'm going to do this but right now my though is to keep rerunning what I already have written until the rating difference is less than the Max. Once that is done it should be relatively simple to split the teams into their own columns. Once I get back to work on Monday and finish my actual work, I'll come revisit this for you.

Sub Team()

Dim lrow As Integer
Dim NumTeams As Integer
Dim x As Integer
Dim i As Integer

NumTeams = Range("Z1")
lrow = Cells(Rows.Count, 1).End(xlUp).Row
TTotal = (lrow - 1) / NumTeams
x = 1

For i = 2 To lrow
Cells(i, 3) = WorksheetFunction.RandBetween(1, 100)
Next i

Columns("A:C").Sort key1:=Range("C2"), order1:=xlDescending, Header:=xlYes
Columns(3).ClearContents

Do Until x = NumTeams + 1
    For i = x To lrow - 1 Step NumTeams
        Cells(i + 1, 3) = x
    Next i
    x = x + 1
Loop



End Sub

Sincerely,
Max

 

[EinarG]

Thanks very much! I will start testing tomorrow. I realize that this is a bit complex and really appreciate your help..

 

[Eric W]

Here's a version I came up with. It will handle up to 200 players, and 2-10 teams. Starting with a sheet looking like:

Excel 2012
	A	B	C	D	E	F
1	Players	Ratings		NumTeams		MaxRatingDiff
2	Amy	0		4		0.5
3	Bob	1
4	Cindy	2
5	Doug	3
6	Elaine	4
7	Frank	5
8	Gail	6
9	Hank	7
10	Isaac	8
11	Jane	9
12	Kim	10
13	Louise	10
14	Mark	9
15	Nancy	8
16	Oscar	7
17	Pam	6
18	Quincy	5
19	Rachel	4
20	Stan	3
21	Terry	2
22	Ursula	1
23	Victor	5
24	Wendy	6
Sheet1

It creates a sheet looking like:

Excel 2012
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S
1	Players	Ratings		NumTeams		MaxRatingDiff			Team A			Team B			Team C			Team D
2	Amy	0		4		0.5			Frank	5		Stan	3		Terry	2		Ursula	1
3	Bob	1							Rachel	4		Nancy	8		Wendy	6		Jane	9
4	Cindy	2							Quincy	5		Pam	6		Isaac	8		Kim	10
5	Doug	3							Mark	9		Oscar	7		Victor	5		Doug	3
6	Elaine	4							Hank	7		Bob	1		Louise	10		Elaine	4
7	Frank	5							Cindy	2		Gail	6		Amy	0
8	Gail	6
9	Hank	7								5.333333			5.166667			5.166667			5.4
10	Isaac	8
11	Jane	9
12	Kim	10
13	Louise	10
14	Mark	9
15	Nancy	8
16	Oscar	7
17	Pam	6
18	Quincy	5
19	Rachel	4
20	Stan	3
21	Terry	2
22	Ursula	1
23	Victor	5
24	Wendy	6
Sheet1

You can run it over and over if you want to see different options.

1) Open your workbook
2) Press Alt-F11 to open the VBA editor
3) From the menu, select Insert --> Module
4) Paste the following code:

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
' 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, or try again with a higher MaxRatingDiff."
    MsgBox MyText
    Exit Sub
    
' Print the teams
PrintTeams:
    Range("J1:AP100").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)

' 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

5) Return to Excel by pressing Alt-F11 again, or by clicking on the Excel window.
6) Press Alt-F8 to get the macro selection box
7) Choose MakeTeams and click Run.

If you need help setting up a hot key for the macro, or a Commandbutton, let me know.

Let me know how it works.

 

[EinarG]

Eric - that looks brilliant! Appears to be exactly what I was looking for. I will test this and provide further feedback. Thanks very much...

Einar

 

[Eric W]

I just noticed that I missed your request that the teams be sorted in descending order of rating. Here's a version that includes that. I also made a few other tweaks to it, mostly adding some extra error checking and improving the sort.

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
' 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")
        If Not IsNumeric(Players(r - 1, 2)) Then
            MsgBox "One of the ratings is not a number."
            Exit Sub
        End If
        r = r + 1
    Wend
    NumPlayers = r - 2
    
' Figure out the team sizes
    If NumTeams > NumPlayers Then
        MsgBox "You must have at least 1 player per team.  Make sure there are no gaps in the player list."
        Exit Sub
    End If
    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 < 250
        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 250 tries." & Chr(10) & Chr(10)
    MyText = MyText & "You may try again, or try again with a higher MaxRatingDiff."
    MsgBox MyText
    Exit Sub
    
' Print the teams
PrintTeams:
    Range("I1:AP100").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
        
        With ActiveSheet.Sort
            .SortFields.Clear
            .SortFields.Add Key:=Cells(2, c + 1), Order:=xlDescending
            .SetRange Range(Cells(2, c), Cells(TeamSize(1) + 1, c + 1))
            .Apply
        End With
        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)

' 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 - i
            If Players(j, 3) > Players(j + 1, 3) Then
                a = Players(j, 1)
                b = Players(j, 2)
                c = Players(j, 3)
                Players(j, 1) = Players(j + 1, 1)
                Players(j, 2) = Players(j + 1, 2)
                Players(j, 3) = Players(j + 1, 3)
                Players(j + 1, 1) = a
                Players(j + 1, 2) = b
                Players(j + 1, 3) = c
            End If
        Next j
    Next i
    
End Sub

 

[EinarG]

Eric - that worked perfectly! I made some minor changes to suit my situation. All my changes are commented in the code below just for reference. I want to send you a sample of my test results but I'm new to this forum could not quickly find the steps to post a screen shot (Could you reply with that?). The only thing I need to change is to have the totals for each team appear in a fixed row further down in the sheet(e.g. 63). You will notice that I changed the number of iterations to 10,000 and was able to get the difference down to 0.02!!

Einar

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
' Written by Eric W.  1/9/2016


' How many teams?
    NumTeams = Range("paNumTeams").Value 'EG-Changed D2 to Named range
    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, "C") <> ""  'EG-Names are actually in C (Changed from A)
        If r > 201 Then
            MsgBox "The number of players must be under 200."
            Exit Sub
        End If
        Players(r - 1, 1) = Cells(r, "C") 'EG-Names in C (Changed from A)
        Players(r - 1, 2) = Cells(r, "D") 'EG-Rating in D (Changed from B)
        If Not IsNumeric(Players(r - 1, 2)) Then
            MsgBox "One of the ratings is not a number."
            Exit Sub
        End If
        r = r + 1
    Wend
    NumPlayers = r - 2
    
' Figure out the team sizes
    If NumTeams > NumPlayers Then
        MsgBox "You must have at least 1 player per team.  Make sure there are no gaps in the player list."
        Exit Sub
    End If
    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 < 10000
        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 <= Range("paMaxRatingDiff").Value Then GoTo PrintTeams 'EG-Changed to Name Range [Was Cells(2, "F")]
        
' Nope, try again
        trials = trials + 1
    Wend
    
    MyText = "Unable to find a valid set of teams in 10,000 tries." & Chr(10) & Chr(10)
    MyText = MyText & "You may try again, or try again with a higher MaxRatingDiff."
    MsgBox MyText
    Exit Sub
    
' Print the teams
PrintTeams:
    Range("E2:P100").ClearContents 'EG-only using up to 6 teams (12 columns) and don't want to clear titles..changed from I1:AP100
    ctr = 1
    For i = 1 To NumTeams
        c = i * 2 + 3 'EG-changed to start in col E and use two columns per team with no blank columns in between (was i*3+6)
        'Cells(1, c) = "Team " & Chr(64 + i) EG-Don't need this as I'm using fixed column titles
        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
        
        With ActiveSheet.Sort
            .SortFields.Clear
            .SortFields.Add Key:=Cells(2, c + 1), Order:=xlDescending
            .SetRange Range(Cells(2, c), Cells(TeamSize(1) + 1, c + 1))
            .Apply
        End With
        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)


' 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 - i
            If Players(j, 3) > Players(j + 1, 3) Then
                a = Players(j, 1)
                b = Players(j, 2)
                c = Players(j, 3)
                Players(j, 1) = Players(j + 1, 1)
                Players(j, 2) = Players(j + 1, 2)
                Players(j, 3) = Players(j + 1, 3)
                Players(j + 1, 1) = a
                Players(j + 1, 2) = b
                Players(j + 1, 3) = c
            End If
        Next j
    Next i

 

[Eric W]

Wow, nice job! Well done modifying it to your needs. A .02 difference is a lot closer than I thought you'd be able to get to.

In order to put the team rating in a fixed row, change this line near the end of the first sub:

Cells(TeamSize(1) + 3, c + 1) = TeamRating(i)

to

Cells([COLOR="#FF0000"]63[/COLOR], c + 1) = TeamRating(i)

I also noticed that this line near the top:

If Not IsNumeric(Players(r - 1, 2)) Then

should be changed to:

If Not IsNumeric(Players(r - 1, "[COLOR="#FF0000"]D[/COLOR]")) Then

in order to find non-numeric ratings.


If you'd like to post a sample of your worksheet, here's a link to where you can get the HTML Maker.

http://www.mrexcel.com/forum/about-board/508133-attachments.html

 

[chuckf201]

Wow, nice job! Well done modifying it to your needs. A .02 difference is a lot closer than I thought you'd be able to get to.

In order to put the team rating in a fixed row, change this line near the end of the first sub:

Cells(TeamSize(1) + 3, c + 1) = TeamRating(i)

to

Cells([COLOR=#FF0000]63[/COLOR], c + 1) = TeamRating(i)

I also noticed that this line near the top:

If Not IsNumeric(Players(r - 1, 2)) Then

should be changed to:

If Not IsNumeric(Players(r - 1, "[COLOR=#FF0000]D[/COLOR]")) Then

in order to find non-numeric ratings.


If you'd like to post a sample of your worksheet, here's a link to where you can get the HTML Maker.

http://www.mrexcel.com/forum/about-board/508133-attachments.html

Max,
Great solution-thanks.
I was looking for a solution to random teams for billiards. You did it.
I plan on enhancing with min diff between max and min, or iterate until std dev is minimum for all teams.
Chuck

 

[EinarG]

Chuck - I used Eric W's code as part of a significant project to create an event management solution for an 8-ball billiards league. If you would like a copy of the documentation, let me know and I will send it to you so you can decide if you want the program itself (no fees involved) to play with. It is well tested after almost 5 months of use - although I continue to tinker with it from time to time.
Einar G