Random Team Scheduler Over Multiple Weeks

foxhound

Board Regular
Joined
Mar 21, 2003
Messages
182
<body>
<p>Hi All,</p><p>I need help trying to make a team scheduler for a non-profit league using XL2003/7. I need to pick random opponents over an 8 week period for each team with no team playing each other more than once, and only playing one game each week. The number of teams can vary year-to-year, so if that can be dynamic, even better! Below is the layout I'm hoping to achieve. Any help would be greatly and sincerely appreciated! :)</p>
<p></p>
<table border="1"; style="width:500px">
<tr>
<th>Team ID</th>
<th>Week 1</th>
<th>Week 2</th>
<th>Week 3</th>
<th>Week 4</th>
<th>Week 5</th>
<th>Week 6</th>
<th>Week 7</th>
<th>Week 8</th>
</tr>
<tr>
<td>100</td>
<td>650</td>
<td>600</td>
<td>550</td>
<td>500</td>
<td>450</td>
<td>400</td>
<td>350</td>
<td>300</td>
</tr>
<tr>
<td>150</td>
<td>600</td>
<td>500</td>
<td>400</td>
<td>300</td>
<td>200</td>
<td>650</td>
<td>550</td>
<td>450</td>
</tr>
<tr>
<td>200</td>
<td>550</td>
<td>450</td>
<td>350</td>
<td>250</td>
<td>150</td>
<td>600</td>
<td>500</td>
<td>400</td>
</tr>
<tr>
<td>250</td>
<td>500</td>
<td>400</td>
<td>300</td>
<td>200</td>
<td>650</td>
<td>550</td>
<td>450</td>
<td>350</td>
</tr>
<tr>
<td>300</td>
<td>450</td>
<td>350</td>
<td>250</td>
<td>150</td>
<td>600</td>
<td>500</td>
<td>400</td>
<td>100</td>
</tr>
<tr>
<td>350</td>
<td>400</td>
<td>300</td>
<td>200</td>
<td>650</td>
<td>550</td>
<td>450</td>
<td>100</td>
<td>250</td>
</tr>
<tr>
<td>400</td>
<td>350</td>
<td>250</td>
<td>150</td>
<td>600</td>
<td>500</td>
<td>100</td>
<td>300</td>
<td>200</td>
</tr>
<tr>
<td>450</td>
<td>300</td>
<td>200</td>
<td>650</td>
<td>550</td>
<td>100</td>
<td>350</td>
<td>250</td>
<td>150</td>
</tr>
</table>
</body>
 

foxhound

Board Regular
Joined
Mar 21, 2003
Messages
182
Okay... I've been working with this, and the below gets me close. However, it seems to get caught in a loop and I can't figure out why yet.

Sub CreateLeagueSchedule()
Dim wk As Integer
Dim rngWeek As Range
Dim rngTeamSched As Range
Dim lngRndTeam As Long
Dim lngTeam As Long
Dim lngNumWeeks As Long
Dim MaxTries As Long

On Error GoTo Err_CreateLeagueSchedule

lngTeam = 1 + Range("tTEAMID").Rows.Count
lngNumWeeks = 8 + 1 'Add one to account for TeamID column

For wk = 2 To lngNumWeeks
Set rngWeek = Range(Cells(2, wk), Cells(lngTeam, wk))

MaxReachedReTry:
Range(Cells(2, wk), Cells(lngTeam, wk)).ClearContents
For Each c In rngWeek
Set rngTeamSched = Nothing
Set rngTeamSched = Range(Cells(c.row, 1), Cells(c.row, lngNumWeeks))

MaxTries = 0
TeamScheduled:
If MaxTries > lngTeam Then GoTo MaxReachedReTry
lngRndTeam = GetNewTeam
If CheckTeam(rngWeek, lngRndTeam, rngTeamSched) = False Then
c.Value = lngRndTeam
Else
MaxTries = MaxTries + 1
GoTo TeamScheduled
End If
Next c
Next wk

Exit Sub

Err_CreateLeagueSchedule:
MsgBox Err.Description
Set rngTeamSched = Nothing
Set rngWeek = Nothing
' Resume Next
Exit Sub

End Sub

Function GetNewTeam()
Dim e
Static myList As Object
If myList Is Nothing Then
Set myList = CreateObject("System.Collections.SortedList")
End If
If myList.Count = 0 Then
Randomize
For Each e In Range("tTEAMID").Value
myList.Item(Rnd) = e
Next
End If
GetNewTeam = myList.GetByIndex(0)
myList.RemoveAt 0
End Function

Function CheckTeam(rngWeek As Range, lngRndTeam As Long, rngTeamSched As Range)
Dim result As String
If (WorksheetFunction.CountIf(rngWeek, lngRndTeam)) + (WorksheetFunction.CountIf(rngTeamSched, lngRndTeam)) = 0 Then
result = "False"
Else: result = "True"
End If
CheckTeam = result
End Function
 

Forum statistics

Threads
1,082,387
Messages
5,365,155
Members
400,826
Latest member
dnathanson

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top