Sub MakeTeams()
Dim Players(200, 3), TeamSize(12) As Integer, TeamRating(12) As Double
'0=team sort order
'1=name
'2=hcp
'3=dist
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 Long
Dim t As Integer, tc As Integer, MaxRating As Double, MinRating As Double
' Written by Eric W. 1/9/2016
' http://www.mrexcel.com/forum/excel-questions/913053-visual-basic-applications-randomly-select-teams-list-players.html
' How many teams?
NumTeams = Range("E2").Value
If NumTeams > 12 Or NumTeams < 2 Or Int(NumTeams) <> NumTeams Then
MsgBox "The number of teams must be an integer from 2-12."
Exit Sub
End If
' Read all the players and ratings
r = 2 'column 2
Erase Players, TeamSize, TeamRating
While Cells(r, "B") <> "" 'last name in list
If r > 201 Then
MsgBox "The number of players must be under 200."
Exit Sub
End If
Players(r - 1, 1) = Cells(r, "B") 'last name column 1
Players(r - 1, 2) = Cells(r, "C") 'handicap column 2
'If Not IsNumeric(Players(r - 1, "D")) Then 'eric change
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 < Range("H2") 'maximum iterations
Call Shuffle(Players, Numplayers)
Dim lDistrib As Long
' 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, "G") Then GoTo PrintTeams 'Met our target****************
' Nope, try again
Range("I2").Value = trials 'can we count?
trials = trials + 1
Wend
MyText = "Unable to find a valid set of teams in " & Range("H2") & " 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:
'--------------------------------------
Dim sStdDev As Single 'find std dev of team
'Dim sAvg As Single 'find average of team
'Dim sSumSq As Single
'--------------------------------------
Range("I2").Value = trials 'number of trials completed
'Make a copy of current teams
Range("K1:AS20").Copy _
Destination:=Range("CC1") 'CMF
Range("CC1:CT10").Columns.AutoFit
Range("K1:AS20").ClearContents 'cut if down to keep std dev and average cells
ctr = 1
' For i = 1 To Numplayers 'NumTeams 'NumTeams 'try to sort teams by team leader handicap
' ' get hcp of team leaders
' Debug.Print Players(i, 0), Players(i, 1), Players(i, 2) 'order
' 'Debug.Print Players(i, 1) 'lname
' 'Debug.Print Players(i, 2) 'hcp
' 'Debug.Print "**"
' 'For j = 1 To TeamSize(i)
'
' 'Next j
'
' Next i
For i = 1 To NumTeams
sAvg = 0 'get std Dev for Teams
c = i * 3 + 8 'space to next team
Cells(1, c) = "Team " & Chr(64 + i) 'start with 'A' in hex
Cells(1, c + 1) = "HCP"
Cells(1, c + 2) = "Dist"
For j = 1 To TeamSize(i)
Cells(j + 1, c) = Players(ctr, 1) 'name
Cells(j + 1, c + 1) = Players(ctr, 2) 'HCP
'Cells(j + 1, c + 2) = WorksheetFunction.NormDist(Cells(j + 1, c + 1), TeamRating(i), sStdDev, 0)
ctr = ctr + 1 'counter for teams
Next j
'sStdDev = WorksheetFunction.StDev(Players(1, 2), Players(2, 2), Players(3, 2), Players(4, 2)) 'OK .2226
sStdDev = WorksheetFunction.StDev(Players(1 * i, 2), Players(2 * i, 2), Players(3 * i, 2), Players(4 * i, 2)) '????
'Cells(40, C + 1) = sStdDev
'Cells(41, C + 1) = TeamRating(i)
For j = 1 To TeamSize(i) 'normal distribution
Cells(j + 1, c + 2) = WorksheetFunction.NormDist(Cells(j + 1, c + 1), TeamRating(i), sStdDev, 0)
'Cells(49 + j, C + 2).Formula = "=NORMDIST(cells(j+1,C+1),teamrating(i),sstddev,0)" 'not ok-put formula
'Cells(59 + j, C + 2).Formula = "=NORMDIST(L3,L27,L28,0)" 'ok
Next j
'ADD SORT ON TEAMS BASED UPON PLAYER 1'S HANDICAP for each team
With ActiveSheet.Sort 'SORT EACH TEAM
.SortFields.Clear
.SortFields.Add Key:=Cells(2, c + 1), Order:=xlDescending
.SetRange Range(Cells(2, c), Cells(TeamSize(i) + 1, c + 2))
.Apply
End With
For k = 1 To TeamSize(i) 'For i = 1 To k
SumSq = SumSq + (Players(k, 2) - TeamRating(i)) ^ 2 'Next i
Next k
StdDev = Sqr(SumSq / (k - 1)) 'StdDev = Sqr(SumSq / (k - 1))
' Cells(Numplayers \ NumTeams + 5, c) = TeamRating(i)
Next i
' Sort team by Team Captain rating
For i = 1 To NumTeams
For j = 1 To NumTeams - i
If Cells(2, j * 3 + 9) < Cells(2, j * 3 + 12) Then
sv = Cells(2, j * 3 + 8).Resize(200, 3).Value
Cells(2, j * 3 + 8).Resize(200, 3).Value = Cells(2, j * 3 + 11).Resize(200, 3).Value
Cells(2, j * 3 + 11).Resize(200, 3).Value = sv
End If
Next j
Next i
Range("K1:AB30").Columns.AutoFit 'Re-adjust column width
'Range("K1").Activate
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
