how to create a tennis team roaster 6 players and 32 tennis time slots

S

shripadjosh

New Member
Joined
Feb 22, 2021
Messages
4
Office Version
  1. 365
Platform
  1. Windows
hello - I need help to create team roaster.

We have 6 players and we play tennis once a week for 32 weeks.

We only need 4 players per week to play doubles.

How do I create roaster of 4 players using available 6 players for 32 weeks and still make sure there is equal rotation? I know some players may get to play more than others...

Appreciate any help!

Thanks,
Shri
 

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
Sort by date Sort by votes
Well, this is an equal rotation.

1614031584923.png


But do you want the same players playing each other or would you randomize it more?

The question isn't what you want to achieve but how you want to go about achieving it.
 
Upvote 0
thanks.

How do I randomize it more to make a non repeating combinations with 4 players?

Week 1
Player 1, 2 ,3 and 4

Week 2
Player 4, 5 ,6 and 1

Week 3
Player 2, 3 ,4 and 6
-----
-----
------
Week32
 
Upvote 0
Here is a way using VBA.

Tennis.xlsm
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAH
1Player ListWk 1Wk 2Wk 3Wk 4Wk 5Wk 6Wk 7Wk 8Wk 9Wk 10Wk 11Wk 12Wk 13Wk 14Wk 15Wk 16Wk 17Wk 18Wk 19Wk 20Wk 21Wk 22Wk 23Wk 24Wk 25Wk 26Wk 27Wk 28Wk 29Wk 30Wk 31Wk 32
2Player 1XXXXXXXXXXXXXXXXXXXX
3Player 2XXXXXXXXXXXXXXXXXXXX
4Player 3XXXXXXXXXXXXXXXXXXXXX
5Player 4XXXXXXXXXXXXXXXXXXXXXX
6Player 5XXXXXXXXXXXXXXXXXXXX
7Player 6XXXXXXXXXXXXXXXXXXX
Sheet1


VBA Code: 
Sub TENNIS()
Dim AL As Object: Set AL = CreateObject("System.Collections.ArrayList")
Dim RES() As Variant: ReDim RES(1 To 6, 1 To 32)
Dim r As Integer

For wk = 1 To 32
    For PLY = 1 To 4
        If AL.Count = 0 Then fillAL AL
        r = AL.Item(Int((AL.Count) * Rnd()))
        AL.Remove r
        RES(r, wk) = "X"
    Next PLY
Next wk

Range("C2").Resize(UBound(RES), UBound(RES, 2)).Value = RES

End Sub

Sub fillAL(AL As Object)
AL.Clear
For i = 1 To 6
    AL.Add i
Next i
End Sub

And here is the distribution of the games.

Tennis.xlsm
CD
9Player ListCount
10Player 120
11Player 220
12Player 321
13Player 422
14Player 520
15Player 619
Sheet1
 
Upvote 0
Small code change.

Tennis.xlsm
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAK
1Player ListWk 1Wk 2Wk 3Wk 4Wk 5Wk 6Wk 7Wk 8Wk 9Wk 10Wk 11Wk 12Wk 13Wk 14Wk 15Wk 16Wk 17Wk 18Wk 19Wk 20Wk 21Wk 22Wk 23Wk 24Wk 25Wk 26Wk 27Wk 28Wk 29Wk 30Wk 31Wk 32Player ListCount
2Player 1XXXXXXXXXXXXXXXXXXXXPlayer 120
3Player 2XXXXXXXXXXXXXXXXXXXXXPlayer 221
4Player 3XXXXXXXXXXXXXXXXXXXXXXPlayer 322
5Player 4XXXXXXXXXXXXXXXXXXXXXPlayer 421
6Player 5XXXXXXXXXXXXXXXXXXXXXXPlayer 522
7Player 6XXXXXXXXXXXXXXXXXXXXXXPlayer 622
Sheet1


VBA Code: 
Sub TENNIS()
Randomize
Dim AL As Object: Set AL = CreateObject("System.Collections.ArrayList")
Dim RES() As Variant: ReDim RES(1 To 6, 1 To 32)
Dim r As Integer, WK As Integer, PLY As Integer

For WK = 1 To 32
    For PLY = 1 To 4
        If AL.Count = 0 Then fillAL AL, RES, WK
        r = AL.Item(Int((AL.Count) * Rnd()))
        AL.Remove r
        RES(r, WK) = "X"
    Next PLY
Next WK

Range("C2").Resize(UBound(RES), UBound(RES, 2)).Value = RES

End Sub

Sub fillAL(AL As Object, RES() As Variant, WK As Integer)
AL.Clear
For i = 1 To 6
    If RES(i, WK) <> "X" Then AL.Add i
Next i
End Sub
 
Upvote 0
lrobbo314 said:
Small code change.

Tennis.xlsm
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAK
1Player ListWk 1Wk 2Wk 3Wk 4Wk 5Wk 6Wk 7Wk 8Wk 9Wk 10Wk 11Wk 12Wk 13Wk 14Wk 15Wk 16Wk 17Wk 18Wk 19Wk 20Wk 21Wk 22Wk 23Wk 24Wk 25Wk 26Wk 27Wk 28Wk 29Wk 30Wk 31Wk 32Player ListCount
2Player 1XXXXXXXXXXXXXXXXXXXXPlayer 120
3Player 2XXXXXXXXXXXXXXXXXXXXXPlayer 221
4Player 3XXXXXXXXXXXXXXXXXXXXXXPlayer 322
5Player 4XXXXXXXXXXXXXXXXXXXXXPlayer 421
6Player 5XXXXXXXXXXXXXXXXXXXXXXPlayer 522
7Player 6XXXXXXXXXXXXXXXXXXXXXXPlayer 622
Sheet1


VBA Code: 
Sub TENNIS()
Randomize
Dim AL As Object: Set AL = CreateObject("System.Collections.ArrayList")
Dim RES() As Variant: ReDim RES(1 To 6, 1 To 32)
Dim r As Integer, WK As Integer, PLY As Integer

For WK = 1 To 32
    For PLY = 1 To 4
        If AL.Count = 0 Then fillAL AL, RES, WK
        r = AL.Item(Int((AL.Count) * Rnd()))
        AL.Remove r
        RES(r, WK) = "X"
    Next PLY
Next WK

Range("C2").Resize(UBound(RES), UBound(RES, 2)).Value = RES

End Sub

Sub fillAL(AL As Object, RES() As Variant, WK As Integer)
AL.Clear
For i = 1 To 6
    If RES(i, WK) <> "X" Then AL.Add i
Next i
End Sub
Click to expand...
Thank you so much! Is it possible to attach the xlsm file? Thanks again!
 
Upvote 0
I'm not able to use file sharing web sites. You can just copy the code and insert it into a new module.

Go to the VBA editor by hitting Alt+F11.
Click 'Insert', click 'Module, then paste the code.

This updated version of the code gives a better and more consistent result.

Tennis.xlsm
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAI
1Player ListWk 1Wk 2Wk 3Wk 4Wk 5Wk 6Wk 7Wk 8Wk 9Wk 10Wk 11Wk 12Wk 13Wk 14Wk 15Wk 16Wk 17Wk 18Wk 19Wk 20Wk 21Wk 22Wk 23Wk 24Wk 25Wk 26Wk 27Wk 28Wk 29Wk 30Wk 31Wk 32Total
2Player 1XXXXXXXXXXXXXXXXXXXXX21
3Player 2XXXXXXXXXXXXXXXXXXXXXX22
4Player 3XXXXXXXXXXXXXXXXXXXXX21
5Player 4XXXXXXXXXXXXXXXXXXXXX21
6Player 5XXXXXXXXXXXXXXXXXXXXXX22
7Player 6XXXXXXXXXXXXXXXXXXXXX21
Sheet1
Cell Formulas
RangeFormula
AI2:AI7AI2=COUNTA(C2:AH2)


VBA Code: 
Sub TENNIS()
Randomize
Dim AL As Object: Set AL = CreateObject("System.Collections.ArrayList")
Dim RES() As Variant: ReDim RES(1 To 6, 1 To 32)
Dim r As Integer

For WK = 1 To 32
    If AL.Count = 0 Then fillAL AL
    r = Int((AL.Count) * Rnd())
    v = AL(r)
    AL.removeAt r
    For Each i In v
        RES(i, WK) = "X"
    Next i
Next WK

Range("C2").Resize(UBound(RES), UBound(RES, 2)).Value = RES

End Sub

Sub fillAL(AL As Object)
AL.Add Array(1, 2, 3, 4)
AL.Add Array(2, 3, 4, 5)
AL.Add Array(3, 4, 5, 6)
AL.Add Array(1, 2, 3, 6)
AL.Add Array(2, 3, 4, 6)
AL.Add Array(1, 3, 4, 5)
AL.Add Array(1, 4, 5, 6)
AL.Add Array(1, 2, 4, 5)
AL.Add Array(2, 3, 5, 6)
AL.Add Array(1, 3, 4, 6)
AL.Add Array(1, 3, 5, 6)
AL.Add Array(1, 2, 4, 6)
AL.Add Array(1, 2, 5, 6)
AL.Add Array(1, 2, 3, 5)
AL.Add Array(2, 4, 5, 6)
End Sub
 
Upvote 0
lrobbo314 said:
I'm not able to use file sharing web sites. You can just copy the code and insert it into a new module.

Go to the VBA editor by hitting Alt+F11.
Click 'Insert', click 'Module, then paste the code.

This updated version of the code gives a better and more consistent result.

Tennis.xlsm
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAI
1Player ListWk 1Wk 2Wk 3Wk 4Wk 5Wk 6Wk 7Wk 8Wk 9Wk 10Wk 11Wk 12Wk 13Wk 14Wk 15Wk 16Wk 17Wk 18Wk 19Wk 20Wk 21Wk 22Wk 23Wk 24Wk 25Wk 26Wk 27Wk 28Wk 29Wk 30Wk 31Wk 32Total
2Player 1XXXXXXXXXXXXXXXXXXXXX21
3Player 2XXXXXXXXXXXXXXXXXXXXXX22
4Player 3XXXXXXXXXXXXXXXXXXXXX21
5Player 4XXXXXXXXXXXXXXXXXXXXX21
6Player 5XXXXXXXXXXXXXXXXXXXXXX22
7Player 6XXXXXXXXXXXXXXXXXXXXX21
Sheet1
Cell Formulas
RangeFormula
AI2:AI7AI2=COUNTA(C2:AH2)


VBA Code: 
Sub TENNIS()
Randomize
Dim AL As Object: Set AL = CreateObject("System.Collections.ArrayList")
Dim RES() As Variant: ReDim RES(1 To 6, 1 To 32)
Dim r As Integer

For WK = 1 To 32
    If AL.Count = 0 Then fillAL AL
    r = Int((AL.Count) * Rnd())
    v = AL(r)
    AL.removeAt r
    For Each i In v
        RES(i, WK) = "X"
    Next i
Next WK

Range("C2").Resize(UBound(RES), UBound(RES, 2)).Value = RES

End Sub

Sub fillAL(AL As Object)
AL.Add Array(1, 2, 3, 4)
AL.Add Array(2, 3, 4, 5)
AL.Add Array(3, 4, 5, 6)
AL.Add Array(1, 2, 3, 6)
AL.Add Array(2, 3, 4, 6)
AL.Add Array(1, 3, 4, 5)
AL.Add Array(1, 4, 5, 6)
AL.Add Array(1, 2, 4, 5)
AL.Add Array(2, 3, 5, 6)
AL.Add Array(1, 3, 4, 6)
AL.Add Array(1, 3, 5, 6)
AL.Add Array(1, 2, 4, 6)
AL.Add Array(1, 2, 5, 6)
AL.Add Array(1, 2, 3, 5)
AL.Add Array(2, 4, 5, 6)
End Sub
Click to expand...
Thanks again!
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Solved
Generate list of players for four school teams
2
Replies
16
Views
246
imcl75
I
JenniferMurphy
  • Question
How to tally tennis court pairings?
Replies
9
Views
315
JenniferMurphy
JenniferMurphy
K
  • Question
Calculating player win-loss records
Replies
1
Views
532
KWD
K
S
  • Question
analyze and export based on multiple criteria
Replies
0
Views
325
slash32487
S
D
  • Question
Code taking too long to run, unsure of the cause or the resolution
Replies
3
Views
339
offthelip
O

Forum statistics

Threads
1,214,583
Messages
6,120,383
Members
448,956
Latest member
JPav

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top