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