Interesting problem!
Food for thought:
---------------------------------------------------------------------------------------------------------
To determine number of possible combinations
for any number (X) of teams:
n = (X * (X-1))/2
If the teams are aliased 'A', 'B', 'C', 'D', etc., and X = 4, then
n = (4 * 3)/2 = 6
AB, AC, AD, BC, BD, CD
Division by 2 is necessary to eliminate the unwanted reverse possibilities of:
BA, CA, DA, CB, DB, DC
---------------------------------------------------------------------------------------------------------
If you want to play with this, create two tables:
tbl_teams: Fields: Teamname, text; lastplayed (shortdate)
tbl_combos: Fields: Combo, text; dtePlayed (shortdate)
Populate tbl_teams with any number of teamnames, using 'A', 'B', 'C', etc.
Leave field lastplayed blank (you'll have to reset this each time you run the code)
Copy/paste the following code to a module. Note that it calls two user-designed functions (ReverseString and StrCount), which are included. If all goes well, the code will create a schedule in tbl_combos, ensuring that each combination occurs only once.
To test, from the debug window type ? matchem <return>, then open tbl_combos
Function matchem()
'*******************************************
'Name: matchem (Function)
'Purpose: Create schedule of unique team
' combinations.
'*******************************************
Dim db As Database
Dim rs As Recordset, rs2 As Recordset
Dim teamhold As String
Dim txtcombos As String, txtcombos2 As String
Dim strSQL As String
Dim datehold As Date
Dim numteams As Integer
Dim i As Integer, n As Integer
strSQL = "SELECT teamname, lastplayed FROM tbl_teams " _
& "ORDER BY lastplayed, teamname;"
Set db = CurrentDb
Set rs = db.OpenRecordset(strSQL)
'determine number of teams from tbl_teams
rs.MoveLast
numteams = rs.RecordCount
rs.MoveFirst
n = (numteams * (numteams - 1)) / 2 'number of games
txtcombos = ""
Set rs2 = db.OpenRecordset("tbl_combos")
For i = 1 To n
'as written, this provides for
successive game dates
'starting with the current date + 1.
'an alternative would be a separate table populated with
'desired dates (must be in calendar sequence)
datehold = Date + i
rs.MoveFirst
'this loop prevents procedure from stalling
Do While StrCount(txtcombos, rs!TeamName) >= numteams - 1
rs.MoveNext
Loop
teamhold = rs!TeamName
rs.MoveNext
teamhold = teamhold & rs!TeamName
'checks to ensure combination not already used
'either forward or in reverse (e.g. AB or BA)
txtcombos2 = txtcombos & " " & ReverseString(txtcombos)
Do Until InStr(txtcombos2, teamhold) = 0
teamhold = Left(teamhold, 1)
rs.MoveNext
teamhold = teamhold & rs!TeamName
Loop
txtcombos = txtcombos & " " & teamhold
'update tbl_teams
rs.Edit
rs!lastplayed = datehold
rs.Update
rs.MoveFirst
rs.Edit
rs!lastplayed = datehold
rs.Update
rs.Requery
rs.MoveFirst
'update tbl_combos
rs2.AddNew
rs2!combo = teamhold
rs2!dtePlayed = datehold
rs2.Update
Next i
rs2.Close
rs.Close
db.Close
Set db = Nothing
'to see results, open tbl_combos
End Function
Function ReverseString(ByVal linea As String) As String
'This procedure produces a reversal of
'an inputted string.
Dim result As String, i As Integer, n As Integer
n = Len(linea)
result = ""
For i = n To 1 Step -1
result = result & Mid(linea, i, 1)
Next i
ReverseString = result
End Function
Function StrCount(ByVal TheStr As String, theitem As Variant) As Integer
'------------------------------------------------------------------
' PURPOSE: Counts the numbers of times an item occurs
' in a string.
' ARGUMENTS: TheStr: The string to be searched.
' TheItem: The item to search for.
' RETURNS: The number of occurrences as an integer.
'
' NOTES: To test: Type '? StrCount("The quick brown fox jumped over
' the lazy dog", "the") in the debug window.
' The function will return 2.
'------------------------------------------------------------------
Dim strHold As String, itemhold As Variant
Dim placehold As Integer
Dim i As Integer, j As Integer
strHold = TheStr
itemhold = theitem
j = 0
If InStr(1, strHold, itemhold) > 0 Then
While InStr(1, strHold, itemhold) > 0
placehold = InStr(1, strHold, itemhold)
j = j + 1
strHold = Mid(strHold, placehold + Len(itemhold))
Wend
End If
StrCount = j
End Function
