Round Robin

R

rowdy501

New Member
Joined
Dec 4, 2017
Messages
5
Hi, very new to this so please be gentle.

Im trying to make a round robin draw for my local league. 20 players to play each other 3 times, `Ive searched the web and tried all sorts of different things to no avail, please if any help is available would much appreciate it.
 

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
Sort by date Sort by votes
Sounds fun and useful. Somewhat similar to a gift exchange routine that I made before. I'm sure there could be a nifty array or dictionary solution that involves less code (that I likely wouldn't be able to understand) but until that happens, this seems to work. HTH. Dave
Code: 
Option Explicit
Private Sub RoundRobin()
Dim Lastrow As Integer, Cnt As Integer, Cnt2 As Integer, Counter As Integer
Dim FirstRow As Integer, SecondRow As Integer, Cnt3 As Integer
'place in sheet1 sheet code
'list of names in Sheet1 A1 to A whatever
'outputs 3 random games in sheet1 D:F
'ie. Player list in "C" plays against player game 1 in "D"; game 2 in "E"; game 3 in "F"
Randomize
With Sheets("sheet1")
    Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
'clear previous results
Sheets("sheet1").Range(Sheets("sheet1").Cells(1, "B"), _
Sheets("sheet1").Cells(Lastrow, "F")).ClearContents
Sheets("sheet1").Range("A1:A" & Lastrow).Copy Destination:=Sheets("sheet1").Range("C" & 1)
Application.CutCopyMode = False
If Lastrow Mod 2 <> 0 Then
MsgBox "Some one's not playing!"
End If
Cnt2 = 4
Cnt3 = 0
StartAgain:
Cnt = 0
Do
abovefirstrow:
If Cnt > 1000 Then
Sheets("sheet1").Range("B1:B" & Lastrow).ClearContents
Cnt3 = Cnt3 + 1
If Cnt3 = 3 Then
Exit Sub
Else
Counter = 0
Cnt2 = Cnt2 + 1
GoTo StartAgain
End If
End If
FirstRow = Int((Lastrow * Rnd) + 1)
If Sheets("sheet1").Range("B" & FirstRow).Value <> vbNullString Then
Cnt = Cnt + 1
GoTo abovefirstrow
End If
abovesecondrow:
SecondRow = Int((Lastrow * Rnd) + 1)
If Sheets("sheet1").Range("B" & SecondRow).Value <> vbNullString Then
GoTo abovesecondrow
End If
If FirstRow = SecondRow Then
Cnt = Cnt + 1
GoTo abovefirstrow
End If
If Sheets("sheet1").Range("A" & FirstRow).Value = _
           Sheets("sheet1").Range("A" & SecondRow).Value Then
Cnt = Cnt + 1
GoTo abovefirstrow
End If
If Cnt2 = 5 Then
If Sheets("sheet1").Range("A" & SecondRow).Value = Sheets("sheet1").Cells(FirstRow, 4).Value Or _
Sheets("sheet1").Range("A" & FirstRow).Value = Sheets("sheet1").Cells(SecondRow, 4).Value Then
Cnt = Cnt + 1
GoTo abovefirstrow
End If
End If
If Cnt2 = 6 Then
If Sheets("sheet1").Range("A" & SecondRow).Value = Sheets("sheet1").Cells(FirstRow, 4).Value Or _
Sheets("sheet1").Range("A" & FirstRow).Value = Sheets("sheet1").Cells(SecondRow, 4).Value Or _
Sheets("sheet1").Range("A" & SecondRow).Value = Sheets("sheet1").Cells(FirstRow, 5).Value Or _
Sheets("sheet1").Range("A" & FirstRow).Value = Sheets("sheet1").Cells(SecondRow, 5).Value Then
Cnt = Cnt + 1
GoTo abovefirstrow
End If
End If
Sheets("sheet1").Cells(FirstRow, Cnt2).Value = Sheets("sheet1").Range("A" & SecondRow).Value
Sheets("sheet1").Cells(SecondRow, Cnt2).Value = Sheets("sheet1").Range("A" & FirstRow).Value
Sheets("sheet1").Range("B" & FirstRow).Value = "Done"
Sheets("sheet1").Range("B" & SecondRow).Value = "Done"
Counter = Counter + 1
If Counter = Lastrow Then
Sheets("sheet1").Range("B1:B" & Lastrow).ClearContents
Cnt3 = Cnt3 + 1
If Cnt3 = 3 Then
Exit Sub
Else
Counter = 0
Cnt2 = Cnt2 + 1
GoTo StartAgain
End If
End If
Loop
End Sub
edit: I just read your request for players to play each other 3 times. I assumed that it was 3 games against 3 different opponents. I sure hope that's what U meant?
 
Last edited:
Upvote 0
Apparently rowdy501 was just passing through, found a solution elsewhere or just forgot his request. Seems like a very useful routine for all those draw masters out there. So I added some functionality to the routine. U can now enter the players/teams in Sheet1 A1: A& whatever. An input box is provided to enter the number of games in the round robin. A random draw is outputted with no players/teams playing each other twice in the round robin. Note that due to the random nature of the draw generation, blanks may be outputted ie. when generating the last game, if the 2 remaining players/teams have already played each other in the round robin, then a blank is outputted. Run the routine until no blanks are present. If an odd number of players/teams are entered, a warning message is issued and a blank (bye) game will be outputted. Hope this is useful. Dave
ps. Again, I'm sure there could be a nifty dictionary or array solution with a whole lot less code if anyone else wants to contribute.
Place player/teams in Column A starting at A1. Place code in sheet 1 code
Code: 
Option Explicit
Sub RoundRobin()
Dim ToTGames As Integer, ColCnt As Integer, Rng As Range, LastCol As Integer, Icntr As Integer
Dim Lastrow As Integer, Cnt As Integer, ColNum As Integer, Counter As Integer
Dim FirstRow As Integer, SecondRow As Integer, Games As Integer
'place in sheet1 sheet code
'inputbox number of games
'list of names in Sheet1 A1 to A whatever
'outputs random games in sheet1 D: whatever
'ie. Player list in "C" plays against player game 1 in "D"; game 2 in "E"; etc.
ToTGames = Application.InputBox("Enter number of Round Robin games.", Type:=1, _
                                  Title:="ROUND ROBIN GAMES ENTRY")
If ToTGames = 0 Then
MsgBox "No Round Robin games entered!"
Exit Sub
End If
Randomize
With Sheets("sheet1")
Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
LastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
End With
Set Rng = Sheets("sheet1").Range("C1:" & Sheets("sheet1").Cells(2, LastCol) & Lastrow + 1)
For Icntr = LastCol To 4 Step -1
Columns(Icntr).EntireColumn.ClearContents
Next
Sheets("sheet1").Range("C" & 1) = "NAMES"
Sheets("sheet1").Range("A1:A" & Lastrow).Copy Destination:=Sheets("sheet1").Range("C" & 2)
Application.CutCopyMode = False
If Lastrow Mod 2 <> 0 Then
MsgBox "Some one's not playing!"
End If
ColNum = 4
Games = 0
StartAgain:
Cnt = 0
Do
abovefirstrow:
If Cnt > 1000 Then
Sheets("sheet1").Range("B1:B" & Lastrow).ClearContents
Games = Games + 1
If Games = ToTGames Then
Exit Sub
Else
Counter = 0
ColNum = ColNum + 1
GoTo StartAgain
End If
End If
FirstRow = Int((Lastrow * Rnd) + 1)
If Sheets("sheet1").Range("B" & FirstRow).Value <> vbNullString Then
Cnt = Cnt + 1
GoTo abovefirstrow
End If
abovesecondrow:
SecondRow = Int((Lastrow * Rnd) + 1)
If Sheets("sheet1").Range("B" & SecondRow).Value <> vbNullString Then
GoTo abovesecondrow
End If
If FirstRow = SecondRow Then
Cnt = Cnt + 1
GoTo abovefirstrow
End If
If Sheets("sheet1").Range("A" & FirstRow).Value = _
           Sheets("sheet1").Range("A" & SecondRow).Value Then
Cnt = Cnt + 1
GoTo abovefirstrow
End If
If ColNum > 4 Then
For ColCnt = 4 To ColNum
If Sheets("sheet1").Range("A" & SecondRow).Value = Sheets("sheet1").Cells(FirstRow + 1, ColCnt).Value Or _
Sheets("sheet1").Range("A" & FirstRow).Value = Sheets("sheet1").Cells(SecondRow + 1, ColCnt).Value Then
Cnt = Cnt + 1
GoTo abovefirstrow
End If
Next ColCnt
End If
Sheets("sheet1").Cells(1, ColNum).Value = "GAME " & ColNum - 3
Sheets("sheet1").Cells(FirstRow + 1, ColNum).Value = Sheets("sheet1").Range("A" & SecondRow).Value
Sheets("sheet1").Cells(SecondRow + 1, ColNum).Value = Sheets("sheet1").Range("A" & FirstRow).Value
Sheets("sheet1").Range("B" & FirstRow).Value = "Done"
Sheets("sheet1").Range("B" & SecondRow).Value = "Done"
Counter = Counter + 1
If Counter = Lastrow Then
Sheets("sheet1").Range("B1:B" & Lastrow).ClearContents
Games = Games + 1
If Games = ToTGames Then
Exit Sub
Else
Counter = 0
ColNum = ColNum + 1
GoTo StartAgain
End If
End If
Loop
End Sub
 
Upvote 0
Sorry guys for the delay in replying been working away and not had time to try this thank you so much for your time and help as soon as i get chance i will reply with the result.
Again Gent/ladies thank you
 
Upvote 0
Hi Guys I get an error on this line, Set Rng = Sheets("sheet1").Range("C1:" & Sheets("sheet1").Cells(2, LastCol) & Lastrow + 1)
 
Upvote 0
Well that's embarrassing. That line of code wasn't supposed to be there and I'm not sure how it got there? Anyways, this works. Dave
Code: 
Option Explicit
Sub RoundRobin()
Dim ToTGames As Integer, ColCnt As Integer, Rng As Range, LastCol As Integer, Icntr As Integer
Dim Lastrow As Integer, Cnt As Integer, ColNum As Integer, Counter As Integer
Dim FirstRow As Integer, SecondRow As Integer, Games As Integer
'place in sheet1 sheet code
'inputbox number of games
'list of names in Sheet1 A1 to A whatever
'outputs random games in sheet1 D: whatever
'ie. Player list in "C" plays against player game 1 in "D"; game 2 in "E"; etc.
ToTGames = Application.InputBox("Enter number of Round Robin games.", Type:=1, _
                                  Title:="ROUND ROBIN GAMES ENTRY")
If ToTGames = 0 Then
MsgBox "No Round Robin games entered!"
Exit Sub
End If
Randomize
With Sheets("sheet1")
Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
LastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
End With
For Icntr = LastCol To 4 Step -1
Columns(Icntr).EntireColumn.ClearContents
Next
Sheets("sheet1").Range("C" & 1) = "NAMES"
Sheets("sheet1").Range("A1:A" & Lastrow).Copy Destination:=Sheets("sheet1").Range("C" & 2)
Application.CutCopyMode = False
If Lastrow Mod 2 <> 0 Then
MsgBox "Some one's not playing!"
End If
ColNum = 4
Games = 0
StartAgain:
Cnt = 0
Do
abovefirstrow:
If Cnt > 1000 Then
Sheets("sheet1").Range("B1:B" & Lastrow).ClearContents
Games = Games + 1
If Games = ToTGames Then
Exit Sub
Else
Counter = 0
ColNum = ColNum + 1
GoTo StartAgain
End If
End If
FirstRow = Int((Lastrow * Rnd) + 1)
If Sheets("sheet1").Range("B" & FirstRow).Value <> vbNullString Then
Cnt = Cnt + 1
GoTo abovefirstrow
End If
abovesecondrow:
SecondRow = Int((Lastrow * Rnd) + 1)
If Sheets("sheet1").Range("B" & SecondRow).Value <> vbNullString Then
GoTo abovesecondrow
End If
If FirstRow = SecondRow Then
Cnt = Cnt + 1
GoTo abovefirstrow
End If
If Sheets("sheet1").Range("A" & FirstRow).Value = _
           Sheets("sheet1").Range("A" & SecondRow).Value Then
Cnt = Cnt + 1
GoTo abovefirstrow
End If
If ColNum > 4 Then
For ColCnt = 4 To ColNum
If Sheets("sheet1").Range("A" & SecondRow).Value = Sheets("sheet1").Cells(FirstRow + 1, ColCnt).Value Or _
Sheets("sheet1").Range("A" & FirstRow).Value = Sheets("sheet1").Cells(SecondRow + 1, ColCnt).Value Then
Cnt = Cnt + 1
GoTo abovefirstrow
End If
Next ColCnt
End If
Sheets("sheet1").Cells(1, ColNum).Value = "GAME " & ColNum - 3
Sheets("sheet1").Cells(FirstRow + 1, ColNum).Value = Sheets("sheet1").Range("A" & SecondRow).Value
Sheets("sheet1").Cells(SecondRow + 1, ColNum).Value = Sheets("sheet1").Range("A" & FirstRow).Value
Sheets("sheet1").Range("B" & FirstRow).Value = "Done"
Sheets("sheet1").Range("B" & SecondRow).Value = "Done"
Counter = Counter + 1
If Counter = Lastrow Then
Sheets("sheet1").Range("B1:B" & Lastrow).ClearContents
Games = Games + 1
If Games = ToTGames Then
Exit Sub
Else
Counter = 0
ColNum = ColNum + 1
GoTo StartAgain
End If
End If
Loop
End Sub
edit: Tested after posting. Now it works.
 
Last edited:
Upvote 0
I have updated this code to remove the blank games that were occasionally outputted. It's also faster and can address more games played. Place code in sheet code and run the RoundRobin sub to operate. Place players/teams in sheet1 A1:A & whatever. Hope it is useful for U. Dave
Code: 
Option Explicit
Sub RoundRobin()
Dim ToTGames As Integer, ColCnt As Integer, LastCol As Integer, Icntr As Integer
Dim Lastrow As Integer, Cnt As Integer, ColNum As Integer, Counter As Integer, TotLoops As Integer
Dim FirstRow As Integer, SecondRow As Integer, Games As Integer
'place in sheet1 sheet code
'inputbox number of games
'list of names/teams in sheet1 A1 to A whatever
'outputs random games in sheet1 D: whatever
'ie. Player/team list in "C" plays against player game 1 in "D"; game 2 in "E"; etc.
ToTGames = Application.InputBox("Enter number of Round Robin games.", Type:=1, _
                                  Title:="ROUND ROBIN GAMES ENTRY")
If ToTGames = 0 Then
MsgBox "No games entered!"
Exit Sub
End If
With Sheets("sheet1")
Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
LastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
End With
If ToTGames > Lastrow - 1 Then
MsgBox "Too many games entered!"
Exit Sub
End If

Randomize
Application.Calculation = xlManual
For Icntr = LastCol To 2 Step -1
Sheets("sheet1").Columns(Icntr).EntireColumn.ClearContents
Next
Sheets("sheet1").Range("C" & 1) = "NAMES"
Sheets("sheet1").Range("A1:A" & Lastrow).Copy _
                Destination:=Sheets("sheet1").Range("C" & 2)
Application.CutCopyMode = False
If Lastrow Mod 2 <> 0 Then
MsgBox "Some one's not playing!"
End If
ColNum = 4
Games = 0
StartAgain:
Cnt = 0
Do
abovefirstrow:
'cnt is random attempts to create game
If Cnt > 100 Then
'Check for blanks. Remove game and try again
If Counter <> Int(Lastrow / 2) Then
Sheets("sheet1").Range("B1:B" & Lastrow).ClearContents
Sheets("sheet1").Columns(ColNum).ClearContents
Counter = 0
TotLoops = TotLoops + 1
If TotLoops = 20 Then
MsgBox "Try Again!"
Exit Sub
End If
GoTo StartAgain
End If
Sheets("sheet1").Range("B1:B" & Lastrow).ClearContents
Games = Games + 1
If Games = ToTGames Then
Exit Sub
Else
TotLoops = 0
Counter = 0
ColNum = ColNum + 1
GoTo StartAgain
End If
End If
FirstRow = Int((Lastrow * Rnd) + 1)
If Sheets("sheet1").Range("B" & FirstRow).Value <> vbNullString Then
Cnt = Cnt + 1
GoTo abovefirstrow
End If
abovesecondrow:
SecondRow = Int((Lastrow * Rnd) + 1)
If Sheets("sheet1").Range("B" & SecondRow).Value <> vbNullString Then
GoTo abovesecondrow
End If
If FirstRow = SecondRow Then
Cnt = Cnt + 1
GoTo abovefirstrow
End If
If Sheets("sheet1").Range("A" & FirstRow).Value = _
           Sheets("sheet1").Range("A" & SecondRow).Value Then
Cnt = Cnt + 1
GoTo abovefirstrow
End If
If ColNum > 4 Then
For ColCnt = 4 To ColNum
If Sheets("sheet1").Range("A" & SecondRow).Value = Sheets("sheet1").Cells(FirstRow + 1, ColCnt).Value Or _
Sheets("sheet1").Range("A" & FirstRow).Value = Sheets("sheet1").Cells(SecondRow + 1, ColCnt).Value Then
Cnt = Cnt + 1
GoTo abovefirstrow
End If
Next ColCnt
End If
Sheets("sheet1").Cells(1, ColNum).Value = "GAME " & ColNum - 3
Sheets("sheet1").Cells(FirstRow + 1, ColNum).Value = Sheets("sheet1").Range("A" & SecondRow).Value
Sheets("sheet1").Cells(SecondRow + 1, ColNum).Value = Sheets("sheet1").Range("A" & FirstRow).Value
Sheets("sheet1").Range("B" & FirstRow).Value = "Done"
Sheets("sheet1").Range("B" & SecondRow).Value = "Done"
Counter = Counter + 1
Loop
Application.Calculation = xlAutomatic
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question Question
20 team round robin golf league schedule - 3 courses
Replies
0
Views
372
dep1969
D
S
  • Question Question
Auto Sorting League Table
Replies
2
Views
656
arun_eagertolearn
A
W
  • Question Question
Sports Round Robin Dynamic Table
Replies
1
Views
969
Legacy 143009
L
A
  • Question Question
Take screenshots & simultaneously capture the link, place it into an Excel file which is linked to a FileMaker/Claris db.
Replies
3
Views
389
Dan_W
D
G
  • Solved
Skins Game Conditional Formatting
2
Replies
16
Views
2K
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,223,893
Messages
6,175,249
Members
452,623
Latest member
Techenthusiast

Share this page

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.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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
Back
Top