Hello,
Does anyone know of a way to put together math teams based on previous abilities? Perhaps history of test scores or GPA?
Thank you,
XJ
Hello,
Does anyone know of a way to put together math teams based on previous abilities? Perhaps history of test scores or GPA?
Thank you,
XJ
.
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
Thank you Logit.
I didn't realize that this can be similar to the sports team generator.
I believe this will work fine.
.
Great !
Merry Christmas
Thanks you too!
There are currently 1 users browsing this thread. (0 members and 1 guests)
Bookmarks