Hi I’m new to this. Please can someone help. I am trying to create 2 teams each week from a list of players. the players have a win percentage next to their names. What I want is to be able to pick 2 even random teams each week based on the win percentage. Can anyone help with how I go about doing this?
Create 2 teams at random based on win percentage


Attach a sample workbook. Make sure there is just enough data to demonstrate your need. Include a BEFORE sheet and an AFTER sheet in the workbook if needed to show the process you're trying to complete or automate. Make sure your desired results are shown, mock them up manually if necessary.
Remember to desensitize the data.

Do the win percentages average to .5? i.e. are these percentages derived only from between the players on the list or are outside events included in the calculation of win percentage?
Creating two teams with equal win percentage totals might not be possible, how much variation between the resulting teams is allowed?

Code
Display MoreOption 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 ' Written by Eric W. 1/9/2016 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 210." 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
Participate now!
Don’t have an account yet? Register yourself now and be a part of our community!