Sports Round Robin Dynamic Table

[Wolfspyda]

Hi team,

I’m trying to create a Custom Dynamic Round Robin table.

The table needs to cater for 4 teams to 18 teams. These Teams will be divided into 3 Divisions, D1, D2 and D3. Each team will play each other once.

So the 1st part is, I need to make an expanding Table based on the number of teams in the division from 4 to 10. If it was 4 teams I need it to Start at say A1=Team1, B1=Team2, A2=Team3 and B2=Team4. The easiest way I can think of it working is to make A1 the “locked” team and the others switch position. So either they rotate clockwise or counter clockwise. Eg, Team2 moves from B1 to B2, Team4 moves from B2 to A2 and Team3 moves from A2 to B1. I need it to rotate in that order until it reaches the start point. I need it to be dynamic so that once it can do this with 4 teams it can expand to 10 teams.

I’m using Power Query to pull the table designs across and then Append the Divisions together into 1 massive draw as all teams play each other. The main focus is that the last Rds are the Div1 Vs Div3, so that in the event the schedule is going beyond the time those games can easily be dropped.

At present my table has the Rounds sorted correctly, however the other issue I have now is that I have the Draw in individual cells. Eg in Cell A1 I have 1 v 2. What I need to do is replace 1 with Team A and 2 with Team B. I know I can split the column replace the values and then join the column back again, but I thought I might be able to use the =Left(IsNumber function to find the 1st number and use the Right(IsNumber to find the 2nd number and then replace both with a concatenate function.

I’m trying to avoid using VBA too as i need to be able to use this on a Mac as well as PC.

 

[Legacy 143009]

Round Robin is a complex algorithm that is very hard to achieve in VBA. This is from one of my previous projects. I hope it fits your needs.
Let say you have several teams in variety of divisions:

Private Function GeneratePlayRobinOdd(ByVal num_teams As Integer) As Integer()
    Dim n2 As Integer
    Dim mid As Integer
    Dim plays() As Integer
    Dim teams() As Integer
    Dim i As Integer
    Dim play As Integer
    Dim team1 As Integer
    Dim team2 As Integer

    n2 = num_teams \ 2
    mid = n2 + 1
    ReDim plays(1 To num_teams, 1 To num_teams)

    ReDim teams(1 To num_teams)
    For i = 1 To num_teams
        teams(i) = i
    Next i

    For play = 1 To num_teams
        For i = 0 To n2 - 1
            team1 = teams(mid - i)
            team2 = teams(mid + i + 1)
            plays(team1, play) = team2
            plays(team2, play) = team1
        Next i

        team1 = teams(1)
        plays(team1, play) = 0

        RotateArray teams
    Next play

    GeneratePlayRobinOdd = plays
End Function
Private Function GenerateplayRobinEven(ByVal num_teams As Integer) As Integer()
    Dim plays() As Integer
    Dim plays2() As Integer
    Dim play As Integer
    Dim team As Integer

    plays = GeneratePlayRobinOdd(num_teams - 1)
    ReDim plays2(1 To num_teams, 1 To num_teams - 1)
    For team = 1 To num_teams - 1
        For play = 1 To num_teams - 1
            If plays(team, play) = 0 Then
                plays2(team, play) = num_teams
                plays2(num_teams, play) = team
            Else
                plays2(team, play) = plays(team, play)
            End If
        Next play
    Next team

    GenerateplayRobinEven = plays2
End Function
Private Function GenerateplayRobin(ByVal num_teams As Integer) As Integer()
    If num_teams Mod 2 = 0 Then
        GenerateplayRobin = GenerateplayRobinEven(num_teams)
    Else
        GenerateplayRobin = GeneratePlayRobinOdd(num_teams)
    End If
End Function
Private Sub RotateArray(teams() As Integer)
    Dim tmp As Integer
    Dim i As Integer

    tmp = teams(UBound(teams))
    For i = UBound(teams) To 2 Step -1
        teams(i) = teams(i - 1)
    Next i
    teams(1) = tmp
End Sub
Private Sub rotateTeams()
    Dim num_teams As Integer
    Dim num_plays As Integer
    Dim plays() As Integer
    Dim team As Integer
    Dim play As Integer
    Dim txt As String
    Dim lRow As Integer, j As Integer
    Dim r As Integer, c As Integer
    Dim tempArr() As String

    For c = 1 To 3
      r = 2
      lRow = Cells(Rows.Count, c).End(xlUp).Row
      num_teams = lRow - 1
      plays = GenerateplayRobin(num_teams)
      For play = 1 To UBound(plays, 2)
          For team = 1 To num_teams
           If team < plays(team, play) Then
                Cells(r, c + 4).Value = Cells(team + 1, c).Value
                Cells(r + 1, c + 4).Value = Cells(plays(team, play) + 1, c).Value
                r = r + 3
            End If
          Next team
      Next play
    Next
End Sub

Run Private Sub rotateTeams() function at the very end. It will generate pairs of matches for each division.