chimp
06-30-2008, 10:06 AM
i have a spreadsheet with some code behind it to generate a set of fixtures for a football/soccer league.
I have a few issues with it though that i need some help with....and with the new season coming up i need help fast...
The code does what it should to a point..
If the team count in a division is equal it generates a full set of fixtures that are required...
If the team count in a division is odd it will create a fixture called crazy punks this will be a free week in effect. (not sure where or how this is done) but it does what i need it to.
where i am struggling is in 2 places.
firstly
if you look at round 1 in the Required Matches worksheet
4 fixtures are scheduled for the same venue this can't happen as one venue can only host one fixture per round.
Secondly
also i would like to split the fixtures about a bit so that teams don't play each other back to back.
you will notice that all teams play each other back to back...i need to prevent this.
... any ideas please.
below is the code behind my worksheet
Option Explicit
Sub GenFixtures()
' Using worksheet functions quite a bit
Dim wsf As WorksheetFunction
Set wsf = Application.WorksheetFunction
Dim mH As Range, mA As Range, mV As Range, mD As Range, mR As Range
Dim tT As Range, tD As Range, tV As Range
' Get all our named columns
With ThisWorkbook
' Should check for screwed up names here
Set tT = .Names("TITeam").RefersToRange
Set tD = .Names("TIDivision").RefersToRange
Set tV = .Names("TIVenue").RefersToRange
Set mH = .Names("RMHome").RefersToRange
Set mA = .Names("RMAway").RefersToRange
Set mV = .Names("RMVenue").RefersToRange
Set mD = .Names("RMDivision").RefersToRange
Set mR = .Names("RMRound").RefersToRange
End With
'If wsf.CountA(mH) > 0 Or wsf.CountA(mA) > 0 Or wsf.CountA(mV) > 0 Or wsf.CountA(mD) > 0 Or wsf.CountA(mR) > 0 Then
' Err.Raise 501, , "Required matches is not empty!"
'End If
mH.Clear: mA.Clear: mV.Clear: mD.Clear: mR.Clear
' Match offset, a row offset into the m ranges
Dim moff As Integer
moff = 1
Dim div As Integer
' Step through each division
For div = wsf.Min(tD) To wsf.Max(tD)
Dim nc As Integer ' Number of competitors
nc = wsf.CountIf(tD, "=" & div)
If nc > 1 Then ' Make sure there are at least two teams in this divison!
' Storing the teams as row offsets
' If odd, nc Mod 2 will be one, this adds our dummy competitor.
ReDim teamOff(1 To nc + nc Mod 2) As Integer
Dim row As Long, comp As Integer
comp = 1
For row = 1 To tD.Rows.Count
If tD.Rows(row).Value = div Then
teamOff(comp) = row
comp = comp + 1
If comp > nc Then
' Don't need to scan the whole 65k cell range.
Exit For
End If
End If
Next row
If comp <> nc + 1 Then Err.Raise 503, , "CountIf function didn't agree with scanning worksheet"
If nc Mod 2 = 1 Then ' Number of competitors is odd
teamOff(nc + 1) = -1 ' Add the dummy competitor
nc = nc + 1
End If
Dim round As Integer, game As Integer
' These loops are 0 based to simplify modulus arithmetic
For round = 0 To nc - 2
Dim home As Integer
Dim away As Integer
For game = 0 To nc / 2 - 1
' This isn't exactly a clockwise rotation but it will get everyone.
If game = 0 Then
home = 1
Else
home = (round + game + nc - 2) Mod (nc - 1) + 2
End If
away = (round + (nc / 2 - 1 - game) + nc - 2 + nc / 2) Mod (nc - 1) + 2
' Don't play a dummy competitor
If teamOff(home) <> -1 And teamOff(away) <> -1 Then
home = teamOff(home)
away = teamOff(away)
mH.Rows(moff).Value = tT.Rows(home).Value
mA.Rows(moff).Value = tT.Rows(away).Value
mV.Rows(moff).Value = tV.Rows(home).Value
mD.Rows(moff).Value = tD.Rows(home).Value
mR.Rows(moff).Value = round * 2 + 1
moff = moff + 1
End If
Next game
' Since it's a double round robin, we just add in the same
' rounds with home and away swapped.
For game = 0 To nc / 2 - 1
' This isn't exactly a clockwise rotation but it will get everyone.
If game = 0 Then
away = 1
Else
away = (round + game + nc - 2) Mod (nc - 1) + 2
End If
home = (round + (nc / 2 - 1 - game) + nc - 2 + nc / 2) Mod (nc - 1) + 2
' Don't play a dummy competitor
If teamOff(home) <> -1 And teamOff(away) <> -1 Then
home = teamOff(home)
away = teamOff(away)
mH.Rows(moff).Value = tT.Rows(home).Value
mA.Rows(moff).Value = tT.Rows(away).Value
mV.Rows(moff).Value = tV.Rows(home).Value
mD.Rows(moff).Value = tD.Rows(home).Value
mR.Rows(moff).Value = round * 2 + 2 ' Round value incremented
moff = moff + 1
End If
Next game
Next round
End If
Next div
End Sub
I have a few issues with it though that i need some help with....and with the new season coming up i need help fast...
The code does what it should to a point..
If the team count in a division is equal it generates a full set of fixtures that are required...
If the team count in a division is odd it will create a fixture called crazy punks this will be a free week in effect. (not sure where or how this is done) but it does what i need it to.
where i am struggling is in 2 places.
firstly
if you look at round 1 in the Required Matches worksheet
4 fixtures are scheduled for the same venue this can't happen as one venue can only host one fixture per round.
Secondly
also i would like to split the fixtures about a bit so that teams don't play each other back to back.
you will notice that all teams play each other back to back...i need to prevent this.
... any ideas please.
below is the code behind my worksheet
Option Explicit
Sub GenFixtures()
' Using worksheet functions quite a bit
Dim wsf As WorksheetFunction
Set wsf = Application.WorksheetFunction
Dim mH As Range, mA As Range, mV As Range, mD As Range, mR As Range
Dim tT As Range, tD As Range, tV As Range
' Get all our named columns
With ThisWorkbook
' Should check for screwed up names here
Set tT = .Names("TITeam").RefersToRange
Set tD = .Names("TIDivision").RefersToRange
Set tV = .Names("TIVenue").RefersToRange
Set mH = .Names("RMHome").RefersToRange
Set mA = .Names("RMAway").RefersToRange
Set mV = .Names("RMVenue").RefersToRange
Set mD = .Names("RMDivision").RefersToRange
Set mR = .Names("RMRound").RefersToRange
End With
'If wsf.CountA(mH) > 0 Or wsf.CountA(mA) > 0 Or wsf.CountA(mV) > 0 Or wsf.CountA(mD) > 0 Or wsf.CountA(mR) > 0 Then
' Err.Raise 501, , "Required matches is not empty!"
'End If
mH.Clear: mA.Clear: mV.Clear: mD.Clear: mR.Clear
' Match offset, a row offset into the m ranges
Dim moff As Integer
moff = 1
Dim div As Integer
' Step through each division
For div = wsf.Min(tD) To wsf.Max(tD)
Dim nc As Integer ' Number of competitors
nc = wsf.CountIf(tD, "=" & div)
If nc > 1 Then ' Make sure there are at least two teams in this divison!
' Storing the teams as row offsets
' If odd, nc Mod 2 will be one, this adds our dummy competitor.
ReDim teamOff(1 To nc + nc Mod 2) As Integer
Dim row As Long, comp As Integer
comp = 1
For row = 1 To tD.Rows.Count
If tD.Rows(row).Value = div Then
teamOff(comp) = row
comp = comp + 1
If comp > nc Then
' Don't need to scan the whole 65k cell range.
Exit For
End If
End If
Next row
If comp <> nc + 1 Then Err.Raise 503, , "CountIf function didn't agree with scanning worksheet"
If nc Mod 2 = 1 Then ' Number of competitors is odd
teamOff(nc + 1) = -1 ' Add the dummy competitor
nc = nc + 1
End If
Dim round As Integer, game As Integer
' These loops are 0 based to simplify modulus arithmetic
For round = 0 To nc - 2
Dim home As Integer
Dim away As Integer
For game = 0 To nc / 2 - 1
' This isn't exactly a clockwise rotation but it will get everyone.
If game = 0 Then
home = 1
Else
home = (round + game + nc - 2) Mod (nc - 1) + 2
End If
away = (round + (nc / 2 - 1 - game) + nc - 2 + nc / 2) Mod (nc - 1) + 2
' Don't play a dummy competitor
If teamOff(home) <> -1 And teamOff(away) <> -1 Then
home = teamOff(home)
away = teamOff(away)
mH.Rows(moff).Value = tT.Rows(home).Value
mA.Rows(moff).Value = tT.Rows(away).Value
mV.Rows(moff).Value = tV.Rows(home).Value
mD.Rows(moff).Value = tD.Rows(home).Value
mR.Rows(moff).Value = round * 2 + 1
moff = moff + 1
End If
Next game
' Since it's a double round robin, we just add in the same
' rounds with home and away swapped.
For game = 0 To nc / 2 - 1
' This isn't exactly a clockwise rotation but it will get everyone.
If game = 0 Then
away = 1
Else
away = (round + game + nc - 2) Mod (nc - 1) + 2
End If
home = (round + (nc / 2 - 1 - game) + nc - 2 + nc / 2) Mod (nc - 1) + 2
' Don't play a dummy competitor
If teamOff(home) <> -1 And teamOff(away) <> -1 Then
home = teamOff(home)
away = teamOff(away)
mH.Rows(moff).Value = tT.Rows(home).Value
mA.Rows(moff).Value = tT.Rows(away).Value
mV.Rows(moff).Value = tV.Rows(home).Value
mD.Rows(moff).Value = tD.Rows(home).Value
mR.Rows(moff).Value = round * 2 + 2 ' Round value incremented
moff = moff + 1
End If
Next game
Next round
End If
Next div
End Sub