I don't where this topic stands, but developing a solution was an interesting exercise. So, here's mine.
The first point to note is that it is fast -- and I mean lightning fast. The 18 team solution takes a fraction of a second. It's been tested for 4, 6, 8, 14, and 18 teams, multiple times for the first 4.
To use the program, run the ScheduleManager subroutine. The output is pairs of teams, with each row representing one week. The output starts in the first empty cell in the current column. Any information in cells to the right is *destroyed*.
The idea behind the algorithm, if any one is interested, is based on analysis of a graph (a la Operations Research). Each team is a node. Arcs connecting the nodes represent legitimate possible pairings.
A valid pairing is found by selecting two nodes that have an arc between them. If all nodes are assigned to a solution, then that solution is feasible. If nodes are left in the graph and there are no arcs between those nodes, then the combinations used so far yield an infeasible solution and must be 'backed out.'
After a solution is found for a given week, the arcs representing the solution are deleted and the problem is solved again.
All possible solutions have been found when no arc remains in the graph.
In developing a solution for a given week, when a node is included in the solution, it (i.e., the node) is dropped from the graph all together. After an acceptable pair is found, the two nodes are removed from the graph, and the reduced problem is then solved.
How is a node-pair selected? The first node in a pair is the first available node in the graph. The second node in the pair is selected with the foll. technique:
First, select a random node that is still in the graph. If this combination results in an infeasible solution somewhere down the line, then revert to the sequential protocol.
If the first (random) selection fails, the second is a sequential selection process. Select, as the 2nd element of the pair, the first available node in the graph. If this results in an infeasible solution, select the next available node.
Implementation of the algorithm in VB:
The graph (nodes and arcs) is implemented by the TeamMap matrix. Since this is not a directed graph, only the upper half of the matrix is needed (but no memory optimization is done -- or needed).
During the development of a week's schedule, nodes are removed from (and, for infeasible solutions, added back to) the graph through the AvailTeams vector.
After a valid pair is found, the reduced graph is solved by the same procedure, which is called recursively.
<pre>
Option Explicit
Sub initializeSystem(ByRef TeamMap() As Byte, _
ByRef AvailTeams() As Byte)
Dim i As Integer, j As Integer
For i = 1 To UBound(TeamMap, 1)
For j = i + 1 To UBound(TeamMap, 1)
TeamMap(i, j) = 1
Next j
Next i
For i = 1 To UBound(AvailTeams)
AvailTeams(i) = 1
Next i
End Sub
Function FirstAvailCompetitor(TeamMap() As Byte, _
ByVal CurrTeam As Integer, AvailTeams() As Byte, _
ByVal StartAfter As Integer) _
As Integer
Dim i As Integer
If StartAfter = 0 Then StartAfter = CurrTeam
For i = StartAfter + 1 To UBound(TeamMap, 2)
If AvailTeams(i) And TeamMap(CurrTeam, i) = 1 Then
FirstAvailCompetitor = i
Exit Function '<<<<<
End If
Next i
End Function
Function FindRandomCompetitor(ByRef TeamMap() As Byte, _
CurrTeam As Integer, AvailTeams() As Byte) _
As Integer
Dim i As Integer, StartAt As Integer
StartAt = Fix(Rnd() * (UBound(TeamMap, 1) - CurrTeam)) _
+ CurrTeam + 1
i = StartAt
Do
If AvailTeams(i) And TeamMap(CurrTeam, i) = 1 Then
FindRandomCompetitor = i
Exit Function '<<<<<
End If
If i = UBound(TeamMap, 2) Then i = CurrTeam + 1 _
Else i = i + 1
Loop Until i = StartAt
End Function
Function FindCompetitor(ByRef TeamMap() As Byte, _
CurrTeam As Integer, AvailTeams() As Byte, _
StartAfter As Integer) As Integer
Dim i As Integer, StartAt As Integer
If StartAfter = 0 Then
FindCompetitor = FindRandomCompetitor( _
TeamMap, CurrTeam, AvailTeams)
Else
FindCompetitor = FirstAvailCompetitor( _
TeamMap, CurrTeam, AvailTeams)
End If
End Function
Function FirstAvailTeam(ByRef AvailTeams() As Byte) As Integer
Dim i As Integer
For i = 1 To UBound(AvailTeams)
If AvailTeams(i) = 1 Then
FirstAvailTeam = i
Exit Function '<<<<<
End If
Next i
End Function
Function schedAPair(ByVal nbrTeams As Integer, _
ByRef TeamMap() As Byte, AvailTeams() As Byte, _
RecursionDepth As Integer, _
ByRef RsltMap() As Integer) As Boolean
Dim T1 As Integer, T2 As Integer, _
Done As Boolean, Success As Boolean, _
FailureCount As Integer
T1 = FirstAvailTeam(AvailTeams)
If T1 = 0 Then 'all teams assigned
schedAPair = True
Exit Function
End If
T2 = FindRandomCompetitor(TeamMap, T1, AvailTeams)
Do
If T2 = 0 Then 'infeasible solution
Done = True
Else
AvailTeams(T1) = 0: AvailTeams(T2) = 0
RsltMap(RecursionDepth, 1) = T1
RsltMap(RecursionDepth, 2) = T2
Success = schedAPair(nbrTeams, TeamMap, AvailTeams, _
RecursionDepth + 1, RsltMap)
If Not Success Then 'Infeasible solution downstream
FailureCount = FailureCount + 1
AvailTeams(T1) = 1: AvailTeams(T2) = 1
RsltMap(RecursionDepth, 1) = 0
RsltMap(RecursionDepth, 2) = 0
T2 = FirstAvailCompetitor(TeamMap, T1, _
AvailTeams, IIf(FailureCount = 1, 0, T2))
End If
Done = Success
End If
Loop Until Done
schedAPair = Success
End Function
Sub printRslt(RsltMap() As Integer)
Dim dest As Range, i As Integer
Set dest = Cells(Cells.Rows.Count, Selection.Column).End(xlUp) _
.Offset(1, 0)
For i = 1 To UBound(RsltMap, 1)
dest.Offset(0, i - 1).Value = RsltMap(i, 1) _
& ", " & RsltMap(i, 2)
Next i
End Sub
Sub updateSystem(ByRef TeamMap() As Byte, _
ByRef RsltMap() As Integer, _
ByRef AvailTeams() As Byte)
Dim i As Integer
For i = 1 To UBound(RsltMap, 1)
TeamMap(RsltMap(i, 1), RsltMap(i, 2)) = 0
RsltMap(i, 1) = 0: RsltMap(i, 2) = 0
Next i
For i = 1 To UBound(AvailTeams)
AvailTeams(i) = 1
Next i
End Sub
Sub ScheduleManager()
Dim nbrTeams As Integer, SchedRslt As Boolean
nbrTeams = Application.InputBox("Enter number of teams (must be an even number)", , 4, , , , , 1)
If nbrTeams Mod 2 = 1 Then
MsgBox "Please enter an even number (2, 4, 6, etc.)"
Exit Sub '<<<<<
End If
ReDim TeamMap(1 To nbrTeams, 1 To nbrTeams) As Byte, _
RsltMap(1 To nbrTeams / 2, 1 To 2) As Integer, _
AvailTeams(1 To nbrTeams) As Byte
'actually need only upper triangle matrix
'(above the main diagonal)
initializeSystem TeamMap, AvailTeams
'Establishes all valid combinations
Do
SchedRslt = schedAPair(nbrTeams, TeamMap, AvailTeams, 1, RsltMap)
If SchedRslt Then
printRslt RsltMap()
updateSystem TeamMap, RsltMap, AvailTeams
End If
Loop While SchedRslt
End Sub
</pre>
