Randomize seating problem

[LenaH]

Dear all,

i have a list of Clubs, as shown below. I would like to avoid having same players from the same clubs sit together.
Is there a way to randomize it?

A table of players usually consists of 4 players. Of course, you can't avoid it fully, but a little randomization would surely help.

Tourney.xlsm
	N	O
1	Player	Club
2	Player 1	LA
3	Player 2	LA
4	Player 3	DE
5	Player 4	LA
6	Player 5	LA
7	Player 6	LA
8	Player 7	LA
9	Player 8	LA
10	Player 9	DE
11	Player 10	DE
12	Player 11	DE
13	Player 12	DE
14	Player 13	DE
15	Player 14	DE
16	Player 15	DE
17	Player 16	DE
18	Player 17	DE
19	Player 18	DE
20	Player 19	LV
21	Player 20	LV
22	Player 21	LV
23	Player 22	LV
24	Player 23	LV
25	Player 24	LV
26	Player 25	LV
27	Player 26	LV
28	Player 27	LV
29	Player 28	LV
30	Player 29	LV
31	Player 30	MN
32	Player 31	MN
33	Player 32	MN
34	Player 33	MN
35	Player 34	CANM
PlayerPool

Any ideas?
Lena

 

[mikerickson]

If there are 4 chairs per table and we know how many total players there are, the number of tables is know.

To distribute the players at those tables to keep team members apart, have the players line up by teams. All of Team A, followed by all of Team B, etc.
The first person in line sits at the first table, the second the second, etc until we reach the end of the tables and then loop back to Table 1.
This seperates all the team members from each other.

To randomize that process, randomize the order of the teams and the order of the players within each team.

Sub test()
    Dim rngData As Range, oneCell As Range
    Dim arrTeams() As String, arrPlayers() As String
    Dim i As Long, j As Long, randIndex As Long, temp As Variant
    
    Dim Pointer As Long, playerPointer As Long, teamStartPointer As Long
    Dim PlayersCount As Long
    Dim Tables() As String
    Dim TablesCount As Long, ChairsPerTable As Long
    Dim tableIndex As Long, ChairIndex As Long
    ChairsPerTable = 4
    
    With Sheet1.Range("A:A")
        Set rngData = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
    End With
    
    PlayersCount = rngData.Rows.Count
    ReDim arrTeams(1 To PlayersCount)
    ReDim arrPlayers(1 To PlayersCount)
    
    Rem make array of unique team names
    Pointer = 0
    For Each oneCell In rngData
        If IsError(Application.Match(oneCell.Offset(0, 1).Value, arrTeams, 0)) Then
            Pointer = Pointer + 1
            arrTeams(Pointer) = oneCell.Offset(0, 1).Value
        End If
    Next oneCell
    ReDim Preserve arrTeams(1 To Pointer)
    
    Rem rand reorder teams
    For i = 1 To Pointer
        randIndex = Int(Rnd() * Pointer) + 1
        temp = arrTeams(randIndex)
        arrTeams(randIndex) = arrTeams(i)
        arrTeams(i) = temp
    Next i
    
    Rem line the players up, all team members together
    playerPointer = 0
    For i = 1 To Pointer

        Rem add players from one team
        teamStartPointer = 0
        For Each oneCell In rngData
            With oneCell
                If oneCell.Offset(0, 1).Value = arrTeams(i) Then
                    playerPointer = playerPointer + 1
                    If teamStartPointer = 0 Then teamStartPointer = playerPointer
                    arrPlayers(playerPointer) = oneCell.Value
                End If
           End With
        Next oneCell
        
        Rem re-order the players of the new team
        For j = teamStartPointer To playerPointer
            randIndex = Int(Rnd() * (playerPointer - teamStartPointer + 1)) + teamStartPointer
            temp = arrPlayers(randIndex)
            arrPlayers(randIndex) = arrPlayers(i)
            arrPlayers(i) = temp
        Next j
    Next i
    
   Rem distribute among the tables
    TablesCount = Application.RoundUp(PlayersCount / ChairsPerTable, 0)
    ReDim Tables(1 To TablesCount, 1 To ChairsPerTable)
    tableIndex = 1: ChairIndex = 1
    
    For i = 1 To PlayersCount
        Tables(tableIndex, ChairIndex) = arrPlayers(i)
        tableIndex = tableIndex + 1
        If TablesCount < tableIndex Then
            tableIndex = 1
            ChairIndex = ChairIndex + 1
        End If
    Next i
    
    Rem output results
    With Range("G:G")
        For i = 1 To TablesCount
            With .Cells(Rows.Count, 1).End(xlUp).Offset(2, 0)
                For j = 1 To ChairsPerTable
                    .Cells(1, j).Value = Tables(i, j)
                Next j
            End With
        Next i
    End With
End Sub

 

[Sulprobil]

Rick,

=INT(N/4) is wrong. 9 players would play at 3 tables. It's CEILING(N,4) and the number of tables with 3 players is MOD(4-MOD(N,4),4).
Or I am wrong

Regards,
Bernd

PS: Nice to meet you again!

 

[Rick Rothstein]

Bernd,

Hmm, aren't you kind... you don't want that last person sitting at the table all by himself.⁉⁉ Yes, of course you are correct... I did not think that one through quite enough.☹ Thanks for catching it.

 

[LenaH]

Thanks for your answers, Rick. It gave me some ideas and found a good way to do it.

If there are 4 chairs per table and we know how many total players there are, the number of tables is know.

To distribute the players at those tables to keep team members apart, have the players line up by teams. All of Team A, followed by all of Team B, etc.
The first person in line sits at the first table, the second the second, etc until we reach the end of the tables and then loop back to Table 1.
This seperates all the team members from each other.

To randomize that process, randomize the order of the teams and the order of the players within each team.

Sub test()
    Dim rngData As Range, oneCell As Range
    Dim arrTeams() As String, arrPlayers() As String
    Dim i As Long, j As Long, randIndex As Long, temp As Variant
  
    Dim Pointer As Long, playerPointer As Long, teamStartPointer As Long
    Dim PlayersCount As Long
    Dim Tables() As String
    Dim TablesCount As Long, ChairsPerTable As Long
    Dim tableIndex As Long, ChairIndex As Long
    ChairsPerTable = 4
  
    With Sheet1.Range("A:A")
        Set rngData = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
    End With
  
    PlayersCount = rngData.Rows.Count
    ReDim arrTeams(1 To PlayersCount)
    ReDim arrPlayers(1 To PlayersCount)
  
    Rem make array of unique team names
    Pointer = 0
    For Each oneCell In rngData
        If IsError(Application.Match(oneCell.Offset(0, 1).Value, arrTeams, 0)) Then
            Pointer = Pointer + 1
            arrTeams(Pointer) = oneCell.Offset(0, 1).Value
        End If
    Next oneCell
    ReDim Preserve arrTeams(1 To Pointer)
  
    Rem rand reorder teams
    For i = 1 To Pointer
        randIndex = Int(Rnd() * Pointer) + 1
        temp = arrTeams(randIndex)
        arrTeams(randIndex) = arrTeams(i)
        arrTeams(i) = temp
    Next i
  
    Rem line the players up, all team members together
    playerPointer = 0
    For i = 1 To Pointer

        Rem add players from one team
        teamStartPointer = 0
        For Each oneCell In rngData
            With oneCell
                If oneCell.Offset(0, 1).Value = arrTeams(i) Then
                    playerPointer = playerPointer + 1
                    If teamStartPointer = 0 Then teamStartPointer = playerPointer
                    arrPlayers(playerPointer) = oneCell.Value
                End If
           End With
        Next oneCell
      
        Rem re-order the players of the new team
        For j = teamStartPointer To playerPointer
            randIndex = Int(Rnd() * (playerPointer - teamStartPointer + 1)) + teamStartPointer
            temp = arrPlayers(randIndex)
            arrPlayers(randIndex) = arrPlayers(i)
            arrPlayers(i) = temp
        Next j
    Next i
  
   Rem distribute among the tables
    TablesCount = Application.RoundUp(PlayersCount / ChairsPerTable, 0)
    ReDim Tables(1 To TablesCount, 1 To ChairsPerTable)
    tableIndex = 1: ChairIndex = 1
  
    For i = 1 To PlayersCount
        Tables(tableIndex, ChairIndex) = arrPlayers(i)
        tableIndex = tableIndex + 1
        If TablesCount < tableIndex Then
            tableIndex = 1
            ChairIndex = ChairIndex + 1
        End If
    Next i
  
    Rem output results
    With Range("G:G")
        For i = 1 To TablesCount
            With .Cells(Rows.Count, 1).End(xlUp).Offset(2, 0)
                For j = 1 To ChairsPerTable
                    .Cells(1, j).Value = Tables(i, j)
                Next j
            End With
        Next i
    End With
End Sub

Wow, Mike, just WOW! I really really appreciate all the work, you put into this. Now it's up to me, to get my stuff together and figure out, how it works and what needs to be edited.
Thanks a lot!

 

[LenaH]

Thanks for everyone contributing to this. In the meantime, I found a way to randomize the seating order but will surely implement Mike's code, later on.

You guys are awesome,
Lena

 

[LenaH]

Drag =RAND() down as a new helper column. Sort by that column, the order will change every time.

That's the way I did it. It works quite alright. - Thanks!

 

[Rick Rothstein]

Drag =RAND() down as a new helper column. Sort by that column, the order will change every time.

That's the way I did it. It works quite alright. - Thanks!

It is possible with this method for you to get three and even four team members at the same table, so you will have to watch out for that.

 

[mikerickson]

If you sort the range with team as the first field and the RAND helper column as the second, that will ranodmize the players, but keep the teams together.
Putting =INDEX($N:$N, 1+4*(ROW(A1)-1)+COLUMN(A1),1) in a cell and dragging right and down to fill a nx4 grid will assign players to tables.