Organising people into teams in Excel

MisterMints

New Member
Joined
Jun 29, 2015
Messages
7
I'm trying to organise an event which is timed. I have asked participants to submit their expected finishing times as part of the application process, and I'm trying to group them into teams accordingly using Excel if possible.

Format looks like this, and continues for 70 rows:

NamePredicted Time
John Smith24:22
Jane Smith32:45
Fred Jones27:50
Emma Jones21:30

I want to group these 70 people into 7 teams of 10, or 10 teams of 7, where each person can only be in a single team, and the entire duration of all predicted times cannot exceed 3:00:00. If it isn't possible to group them into 7x10 or 10x7, then the total predicted time of 3hrs is the more important figure. Happy to give a 10 minute tolerance either way (2:50 - 3:10) on the time. The allocation should also be fairly random, so each team has a selection of fastest, middling, and slowest predicted times in it.

Is this possible?

I struggle to get my head round many of the basic formulae functions in Excel, so as simply as possible please!

Thanks
 

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.

MisterMints

New Member
Joined
Jun 29, 2015
Messages
7
Just to add, I have tried organising these teams by sorting all times from smallest to largest and then giving everyone a number.

Numbering everyone 1-10 means that team 1 will always be fastest and team 10 always the slowest
Numbering the first 10 as 1-10 and the second 10 as 10-1 (and repeat) gets me closer to evenly matched teams, but it is not quite close enough.
 

Logit

Well-known Member
Joined
Aug 31, 2016
Messages
4,301
Let me know if this helps :

VBA Code:
Option Explicit

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
Application.ScreenUpdating = False
Sheets("Sheet1").Range("I2:AK16").Value = ""
' 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
Application.ScreenUpdating = True
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


Teams Gen Based On Rating.xlsm
 

MisterMints

New Member
Joined
Jun 29, 2015
Messages
7
Holy moly! Thank you for writing all of that for me! I'll give it a go a little later.

Where do I put all of this code?

Thanks
 

Logit

Well-known Member
Joined
Aug 31, 2016
Messages
4,301

ADVERTISEMENT

Download the workbook. Link below code.
 

MisterMints

New Member
Joined
Jun 29, 2015
Messages
7
Genius! Thank you so much for your help @Logit

It looks like it works great, but when I tally up the expected results I'm getting too wide a variance. For example, the difference between the smallest total and largest total is almost an hour when it should be as close as possible, but no more that 10-15 minutes. I've tried changing the MaxRatingDiff from as low as 1 up to 7 but it isn't making much of a difference.

Any tips to get tighter results, or anything I can edit in the macro code?

Thanks
 

Forum statistics

Threads
1,148,244
Messages
5,745,596
Members
423,964
Latest member
Rayds

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top