# Organising people into teams in Excel

#### MisterMints

##### New Member
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

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

#### MisterMints

##### New Member
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

Replies
6
Views
321
Replies
9
Views
184
Replies
6
Views
135
Replies
3
Views
371
Replies
3
Views
2K

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.

### Which adblocker are you using?

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

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