Results 1 to 10 of 10

Thread: Round Robin

  1. #1
    New Member
    Join Date
    Dec 2017
    Posts
    5
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Round Robin

    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.

  2. #2
    Board Regular NdNoviceHlp's Avatar
    Join Date
    Nov 2002
    Location
    Manitoba Canada
    Posts
    2,262
    Post Thanks / Like
    Mentioned
    6 Post(s)
    Tagged
    2 Thread(s)

    Default Re: Round Robin

    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 by NdNoviceHlp; Jan 14th, 2018 at 09:32 PM.

  3. #3
    Board Regular NdNoviceHlp's Avatar
    Join Date
    Nov 2002
    Location
    Manitoba Canada
    Posts
    2,262
    Post Thanks / Like
    Mentioned
    6 Post(s)
    Tagged
    2 Thread(s)

    Default Re: Round Robin

    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

  4. #4
    New Member
    Join Date
    Dec 2017
    Posts
    5
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Round Robin

    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

  5. #5
    New Member
    Join Date
    Dec 2017
    Posts
    5
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Round Robin

    Hi Guys I get an error on this line, Set Rng = Sheets("sheet1").Range("C1:" & Sheets("sheet1").Cells(2, LastCol) & Lastrow + 1)

  6. #6
    New Member
    Join Date
    Dec 2017
    Posts
    5
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Round Robin

    Run time error 1004

  7. #7
    Board Regular NdNoviceHlp's Avatar
    Join Date
    Nov 2002
    Location
    Manitoba Canada
    Posts
    2,262
    Post Thanks / Like
    Mentioned
    6 Post(s)
    Tagged
    2 Thread(s)

    Default Re: Round Robin

    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 by NdNoviceHlp; Jan 19th, 2018 at 11:06 AM.

  8. #8
    New Member
    Join Date
    Dec 2017
    Posts
    5
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Round Robin

    Thank you so Much works perfectly

  9. #9
    Board Regular NdNoviceHlp's Avatar
    Join Date
    Nov 2002
    Location
    Manitoba Canada
    Posts
    2,262
    Post Thanks / Like
    Mentioned
    6 Post(s)
    Tagged
    2 Thread(s)

    Default Re: Round Robin

    You are welcome. Thanks for posting your outcome. Dave

  10. #10
    Board Regular NdNoviceHlp's Avatar
    Join Date
    Nov 2002
    Location
    Manitoba Canada
    Posts
    2,262
    Post Thanks / Like
    Mentioned
    6 Post(s)
    Tagged
    2 Thread(s)

    Default Re: Round Robin

    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

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •