Organising people into teams in Excel

[MisterMints]

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:

Name	Predicted Time
John Smith	24:22
Jane Smith	32:45
Fred Jones	27:50
Emma Jones	21: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

 

[MisterMints]

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]

Let me know if this helps :

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]

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]

Download the workbook. Link below code.

 

[MisterMints]

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

 

[Logit]

I hoped the project would suffice for your needs but I understand it's limitations. And "no" ... I don't believe you could edit the code to make it fit your needs.

Here are a resource you might consider :

Learn how to use Solver to allocate players evenly to Teams. A Solver Tutorial.