Option Explicit
' This routine calculates how many of each type of player goes on each team.
' It works by getting the counts from G2:G9, then assigning each type of player
' from left to right, looping back to the first team once we reach the last team.
' Once the count for one type of player is exhausted, the count for the next
' type of player begins at the next team.
'
Sub GetCounts()
Dim Cts() As Long, w As Variant, tots As Variant
Dim i As Long, r As Long, c As Long, t As Long
Application.ScreenUpdating = False
t = Range("I2").Value ' How many teams?
tots = Range("g2:g9").Value ' How many of each type of player?
i = 1 ' Counter
ReDim Cts(1 To t, 1 To 8) ' # of teams, # of each type on the team
r = 1 ' row
c = 1 ' column
Do
If tots(i, 1) = 0 Then ' Exhausted the count of a player type?
i = i + 1 ' Go to next player type
c = c + 1
If i > 8 Then Exit Do ' No more types? Exit
Else
Cts(r, c) = Cts(r, c) + 1 ' Add 1 of this type to team r
tots(i, 1) = tots(i, 1) - 1 ' Decrement # of players of this type
r = r + 1 ' Next team
If r > t Then r = 1 ' Loop back to team 1 if necessary
End If
Loop
' Clear output range
Columns("K:ZZ").ClearContents
' Assign some headings
Cells(11, "J") = "Players/team"
Cells(13, "J") = "Avg team rating"
' Calculate overall team ratings. Type A = 4, B = 3, C = 2, D = 1
' Add up the number of each type and divide by the number of players on the team
w = Array(0, 4, 4, 3, 3, 2, 2, 1, 1)
For i = 1 To t
Cells(1, i + 10) = "Team " & i
For r = 1 To 8
Cells(r + 1, i + 10) = Cts(i, r)
Cells(11, i + 10) = Cells(11, i + 10) + Cts(i, r)
Cells(12, i + 10) = Cells(12, i + 10) + w(r) * Cts(i, r)
Next r
Cells(13, i + 10) = Cells(12, i + 10) / Cells(11, i + 10)
Next i
Application.ScreenUpdating = True
End Sub
' This routine randomly assigns players to teams. First it assigns groups starting with
' "Team" (1 such group per team), then it assigns the rest of the groups, then it assigns
' individuals.
'
Sub PlacePlayers()
Dim WkCts(1 To 8) As Long, Cts As Variant, Players As Variant, Classes As Variant
Dim NumPlayers As Long, NumGroups As Long, NumTGroups As Long, Teams() As Variant
Dim t As Long, i As Long, j As Long, k As Long, Tries As Long, r As Long, r2 As Long
Dim Grp As String, GTCtr() As Long, TeamSize() As Long, TeamNames As Variant
On Error GoTo Oops:
Classes = Array("FA", "MA", "FB", "MB", "FC", "MC", "FD", "MD")
t = Range("I2").Value ' Get number of teams
Cts = Range(Cells(2, "K"), Cells(9, t + 10)).Value ' Get team counts
' Do some validation of the counts
For i = 1 To 8
If WorksheetFunction.Sum(WorksheetFunction.Index(Cts, i, 0)) <> Cells(i + 1, "G") Then
MsgBox "Counts do not add up properly. Rerun 'GetCounts' and adjust accordingly."
Exit Sub
End If
Next i
NumPlayers = Cells(Rows.Count, "A").End(xlUp).Row - 1
If NumPlayers <> WorksheetFunction.Sum(Range("G2:G9")) Then
MsgBox "The totals in G don't sum up to the number of players. Make sure each player" & _
" has a gender and a rating."
Exit Sub
End If
Tries = 0 ' How many times have we tried?
' Initialize all counters. At this point, we're starting from scratch
BigLoop:
Cts = Range(Cells(2, "K"), Cells(9, t + 10)).Value ' Get all team counts
NumPlayers = Cells(Rows.Count, "A").End(xlUp).Row - 1 ' Total # of players
Players = Range("A2:D" & NumPlayers + 1).Value ' Get player list (4 columns)
NumGroups = Evaluate("COUNTA(D2:D" & NumPlayers + 1 & ")") ' # of players in a group
NumTGroups = Evaluate("COUNTIF(D2:D" & NumPlayers + 1 & ",""Team*"")") ' # of players in a "Team" group
ReDim Teams(0 To WorksheetFunction.RoundUp(NumPlayers / t, 0), 1 To t)
ReDim GTCtr(1 To t)
ReDim TeamSize(1 To t)
' At this point, we're looking for a group/player to add
SmallLoop:
' WkCts countains the count of how many of each type of player is in a group
' A group could be a "Team" type group, a regular group, or an individual
Erase WkCts
r = Int(Rnd() * NumPlayers) + 1 ' Pick a random location in the list
If NumGroups > 0 Then ' Any groups left unassigned?
If NumTGroups > 0 Then ' "Team" group unassigned?
While LCase(Left(Players(r, 4), 4)) <> "team" ' From the random spot,
r = (r Mod NumPlayers) + 1 ' go forward until we
Wend ' we find the next "Team" group
Else
While Players(r, 4) = "" ' From the random spot,
r = (r Mod NumPlayers) + 1 ' go forward until we
Wend ' find the next group
End If
Grp = Players(r, 4) ' Save the group name
For i = 1 To NumPlayers ' Find all players in that group
If LCase(Players(i, 4)) = LCase(Grp) Then
j = WorksheetFunction.Match(Players(i, 2) & Players(i, 3), Classes, 0)
WkCts(j) = WkCts(j) + 1
End If
Next i
Else ' Now we're down to placing individuals
j = WorksheetFunction.Match(Players(r, 2) & Players(r, 3), Classes, 0)
WkCts(j) = WkCts(j) + 1
Grp = Chr$(1) ' Create a fake group name for individuals
Players(r, 4) = Chr$(1) ' Make this player look like a 1-player group
End If
' Now we have a group to assign to a team, randomly pick a team, then see if there's
' room on that team for it. If not, try the next team. If the group won't fit on any
' team, we have to start over from scratch.
r2 = Int(Rnd() * t) + 1
For i = 1 To t
If GTCtr(r2) = 1 And LCase(Left(Grp, 4)) = "team" Then GoTo Nope: ' "Team" group?
For j = 1 To 8
If WkCts(j) > Cts(j, r2) Then GoTo Nope:
Next j
GoTo GotOne:
Nope:
r2 = (r2 Mod t) + 1
Next i
' Couldn't find a team that can hold this group
Tries = Tries + 1
If Tries > 1000 Then
MsgBox "Can't find a set of teams in 1000 tries. Check to see that you don't have any unworkable groups, " & _
"such as a group containing 4 male A players, when the maximum number of male A players on any " & _
"team is 3."
Exit Sub
End If
GoTo BigLoop:
GotOne:
If LCase(Left(Grp, 4)) = "team" Then ' We've assigned a "Team" group
GTCtr(r2) = 1
Teams(0, r2) = Grp
End If
' Update counters for this team
For j = 1 To 8
Cts(j, r2) = Cts(j, r2) - WkCts(j)
Next j
' Find all players in this group (or the fake individual group), and add them to the
' team we just found. Then remove those players from the Players array so we don't
' assign them to anyone else.
For i = NumPlayers To 1 Step -1 ' Find the player names to assign
If LCase(Players(i, 4)) = LCase(Grp) Then
TeamSize(r2) = TeamSize(r2) + 1 ' # of players on the team
k = TeamSize(r2)
Teams(k, r2) = Players(i, 1) ' Place the name
For j = 1 To 4 ' Now replace that name with the
Players(i, j) = Players(NumPlayers, j) ' last name on the name list so
Next j ' we don't consider it again
NumPlayers = NumPlayers - 1
If LCase(Left(Grp, 4)) = "team" Then NumTGroups = NumTGroups - 1
If Grp <> Chr$(1) Then NumGroups = NumGroups - 1
End If
Next i
If NumPlayers > 0 Then GoTo SmallLoop: ' Find the next player to place
' Placed everyone, print them out
Range(Cells(1, t + 12), Cells(UBound(Teams) + 1, 2 * t + 11)).Value = Teams
' Check to see if any teams don't have a name. If not, they'll be randomly assigned
' one from the list below. You can put your own names here, or even just skip the
' whole next section (up to the Exit Sub which must remain), and teams without a name
' will just be blank in row 1 on the output.
TeamNames = Array("Maniacs", "Bombers", "Scorpions", "Koalas", "Sharks", "Rednecks", _
"Stretchers", "Raptors", "Ninjas", "Racers")
j = UBound(TeamNames)
For i = 1 To t
If Cells(1, t + 11 + i) = "" Then
k = Int(Rnd() * j)
Cells(1, t + 11 + i) = TeamNames(k)
TeamNames(k) = TeamNames(j)
j = j - 1
End If
Next i
Exit Sub
Oops:
MsgBox "Some error occured. You may need to rerun 'GetCounts' before running this again."
End Sub
