Automating a multi-variable 10 man league schedule

[DButterworth]

Hello All,

I have worked within excel for most of my professional life as a supply chain professional, solving optimization problems and forecasting, but I have been stumped by my friend group! I need help to reclaim my honor, as I have been tasked to help build out a fair and balanced schedule for our magic the gathering league play. The parameters are as follows: each match contains 4 players, there are 10 players in the league, each player has two unique "decks / teams", and the season can be between 8-10 weeks depending on what is best for my schedule optimization. The hope would be to create a schedule that allows every player to see as many unique combinations of players and decks (A/B) in the matches they play, while allowing for the need for 2 people to be on a bye each week.

From all the research I have done their are over 8,000 combinations of play matches, but I have not found a way to generate the schedule formulaically within excel. Please help!

 

[Kaper]

This is an interesting subject. There could be some already existing solutions similar to Need help with a round robin tournament schedule [SOLVED]
What is special to the case - the player could use one of 2 decks.

I haven't studied it from the mathematical point of view, but I used VBA to generate randomized schedules. And while it is relatively easy to generate very good schedules for 8 or 9 weeks, I couldn't find with the tool prepared 10 weeks schedule fulfilling the requirements:
- Noone is on bye for 2 consequtive weeks
- Mr Smith plays with deck X against Mr Brown with deck Y not more than once (but they could play against each other in other match with other decks, so Smith-Y Brown X or even Smith X Brown X and Smith Y and Brown Y are possible).
- number of on-bye weeks is as equal as possible (in 10 weeks and 10 players one shall have 2 on bye and 8 playing weeks, in 9 weeks and 10 players most have 2-7 but 2 will have one on bue and 8 playing, in 8 weeks 4 players 1-7 and remaining 6 2-6

The code is relatively long and as we allow randomized selection and if needed several repetitions - not very quick. For the setup for 8 weeks it takes some 3 seconds to generate trial shcedule and not every schedule fits all requirements, so probably you will have to run it a couple of times.
For 9 weeks it is sometimes also 3-5 seconds, sometimes rather 20. And to find a really good solution you shall probably run the macro more than a few - may be dozen times.
For 10 weeks, I set up an automatic repeating, usually one run took ca 30 seconds and after some 200 runs still havent found fully satisfactory solution.

Still before presenting solution - it is presented with player numbers. So changing sorting on a players list you will get different schedules in real life. Moreover, you can change first 4 columns with next 4 (the tables sequence) in each week. so you can produce different schedule. And filanny, you can sort weeks descending (by week number).

I shall say I had quite fome fun preparing this. And now have some additional toughts, but probably already used too much of my time.

To change number of weeks change is needed only in first line of the code

Dim pairs As Object, rounds(1 To [SIZE=5][B]10[/B][/SIZE], 1 To 10) As String

The code to be inserted in standard module and run with empty sheet being active:

Dim pairs As Object, rounds(1 To 8, 1 To 10) As String
Dim bestpairs As Object, bestrounds(1 To 10, 1 To 10) As String, bestcount As Long


Sub test_assignment()
Dim i As Long, j As Long, m As Long, k As Long, deck As String, available As Object, t As Double
Randomize Now
t = Timer
bestcount = 500
Set bestpairs = CreateObject("Scripting.Dictionary")
For m = 1 To 1000
  Set pairs = CreateObject("Scripting.Dictionary")
  Set available = CreateObject("Scripting.Dictionary")
  For i = 1 To 10
    available.Add CStr(i), 1
  Next i
  For i = 1 To 8
    deck = IIf(Rnd < 0.5, "A", "B") 'could be systematic too  IIf(i Mod 2, "A", "B")
    j = WorksheetFunction.RandBetween(0, available.Count - 1)
    rounds(1, i) = available.Keys()(j) & ";" & deck
    available.Remove available.Keys()(j)
  Next i
  rounds(1, 9) = available.Keys()(0)
  rounds(1, 10) = available.Keys()(1)
  For i = 1 To 3
    For j = i + 1 To 4
      pairs.Add rounds(1, i) & "," & rounds(1, j), 1
      pairs.Add rounds(1, j) & "," & rounds(1, i), 1
  Next j, i
  For i = 5 To 7
    For j = i + 1 To 8
      pairs.Add rounds(1, i) & "," & rounds(1, j), 1
      pairs.Add rounds(1, j) & "," & rounds(1, i), 1
  Next j, i
' prepare next weeks
  For j = 2 To UBound(rounds)
    prepare_week j
  Next j
  j = 0
  For i = 0 To pairs.Count - 1
    If Len(pairs.Items()(i)) > 2 Then j = j + 1
  Next i
  If j < bestcount Then
    bestcount = j
    For i = 1 To UBound(rounds)
      For j = 1 To 10
        bestrounds(i, j) = rounds(i, j)
    Next j, i
    Set bestpairs = pairs
  End If
  If bestcount = 0 Then Exit For
DoEvents
Next m
Rows("2:15").ClearContents
Columns("L:M").ClearContents
Range("A2").Resize(UBound(rounds), 10) = bestrounds
j = 1
For i = 0 To bestpairs.Count - 1
  If Len(bestpairs.Items()(i)) > 2 Then
    j = j + 1
    If j Mod 2 = 0 Then
      Cells(j / 2, "L") = bestpairs.Items()(i)
      Cells(j / 2, "M") = bestpairs.Keys()(i)
    End If
  End If
Next i
show_byes
'Beep
'Debug.Print m, Timer - t
End Sub

Private Sub prepare_week(weeknum As Long)
Dim thisround() As String, available As Object, i As Long, j As Long
Dim playeranddeck As String, deck As String, counter As Long, notused As Boolean
ReDim thisround(1 To 8)
Set available = CreateObject("Scripting.Dictionary")
thisround(1) = rounds(weeknum - 1, 9) & ";" & IIf(Rnd < 0.5, "A", "B")
thisround(5) = rounds(weeknum - 1, 10) & ";" & IIf(Rnd < 0.5, "A", "B")
For i = 1 To 8
  available.Add Split(rounds(weeknum - 1, i), ";")(0), 1
Next i
For i = 2 To 4
  counter = 0
  Do
    notused = True
    counter = counter + 1
    j = WorksheetFunction.RandBetween(0, available.Count - 1)
    deck = IIf(Rnd < 0.5, "A", "B")
    playeranddeck = available.Keys()(j) & ";" & deck
    For k = 1 To i - 1
      If pairs.exists(playeranddeck & "," & thisround(k)) Then notused = False
    Next k
    If Not notused Then
      notused = True
      deck = Replace("AB", deck, "")
      playeranddeck = available.Keys()(j) & ";" & deck
      For k = 1 To i - 1
        If pairs.exists(playeranddeck & "," & thisround(k)) Then notused = False
      Next k
    End If
  Loop Until counter > 1000 Or notused
'  If counter > 1000 Then
' potential to do some extra mixing
'  End If
  available.Remove available.Keys()(j)
  thisround(i) = playeranddeck
Next i

For i = 6 To 8
  counter = 0
  Do
    notused = True
    counter = counter + 1
    j = WorksheetFunction.RandBetween(0, available.Count - 1)
    deck = IIf(Rnd < 0.5, "A", "B")
    playeranddeck = available.Keys()(j) & ";" & deck
    For k = 5 To i - 1
      If pairs.exists(playeranddeck & "," & thisround(k)) Then notused = False
    Next k
    If Not notused Then
      notused = True
      deck = Replace("AB", deck, "")
      playeranddeck = available.Keys()(j) & ";" & deck
      For k = 1 To i - 1
        If pairs.exists(playeranddeck & "," & thisround(k)) Then notused = False
      Next k
    End If
  Loop Until counter > 1000 Or notused
'  If counter > 1000 Then
' potential to do some extra mixing
'  End If
  available.Remove available.Keys()(j)
  thisround(i) = playeranddeck
Next i
For i = 1 To 3
  For j = i + 1 To 4
    If pairs.exists(thisround(i) & "," & thisround(j)) Then
      pairs(thisround(i) & "," & thisround(j)) = pairs(thisround(i) & "," & thisround(j)) & ";" & weeknum
      pairs(thisround(j) & "," & thisround(i)) = pairs(thisround(j) & "," & thisround(i)) & ";" & weeknum
    Else
      pairs.Add thisround(i) & "," & thisround(j), weeknum
      pairs.Add thisround(j) & "," & thisround(i), weeknum
    End If
Next j, i

For i = 5 To 7
  For j = i + 1 To 8
    If pairs.exists(thisround(i) & "," & thisround(j)) Then
      pairs(thisround(i) & "," & thisround(j)) = pairs(thisround(i) & "," & thisround(j)) & ";" & weeknum
      pairs(thisround(j) & "," & thisround(i)) = pairs(thisround(j) & "," & thisround(i)) & ";" & weeknum
    Else
      pairs.Add thisround(i) & "," & thisround(j), weeknum
      pairs.Add thisround(j) & "," & thisround(i), weeknum
    End If
Next j, i
For i = 1 To 8
  rounds(weeknum, i) = thisround(i)
Next i
rounds(weeknum, 9) = available.Keys()(0)
rounds(weeknum, 10) = available.Keys()(1)

End Sub

Private Sub show_byes()
Dim i As Long, j As Long, k As Long, inparr() As Variant, outarr(1 To 10, 1 To 2) As Variant
inparr = Range(Cells(2, "I"), Cells(Rows.Count, "J").End(xlUp)).Value
For i = 1 To UBound(inparr)
  For j = 1 To 2
    outarr(inparr(i, j), 2) = outarr(inparr(i, j), 2) & ";" & i
  Next j
Next i
For i = 1 To UBound(outarr)
 outarr(i, 1) = i
 outarr(i, 2) = Mid(outarr(i, 2), 2)
Next i
Range("O1").Resize(UBound(outarr), 2) = outarr
End Sub

You may dowload file with the code and sheets for 8, 9, (and attempts to 10 weeks) from
http://excel.bucki.pl/forums/generate_tournament_10rd_2dck_2x4pl_2bye.xlsm