All posible sequences of 10 playes - URGENT

Maybe I am missing something but if everyone has to play everyone else twice what do you need random selection for?

With Excel just draw a grid with Players across top and down the sides.  Knock out the diagonal (player one versus player one, etc.).  Whenever a pair play you tick the relevant crossovers for each.  Two ticks in every square and you're done.

Are you looking to create a play order for the matches randomly (assuming youmonly have one pool table)?

Sorry RogueSolutions,

Yes, i am looking to create a play order for the matches randomly and yes there is only one pool table.

This better not be a school assignment, or I'm in trouble... ;)

    Public Players(1 To 10) As String
    Public Matches(1 To 90)
   
     
    Sub Main()
   
        Call PopulatePlayers
        Call GenerateMatches
        Call OutputMatches("C:\UnshuffledMatches.txt")
        Call ShuffleMatches
        Call OutputMatches("C:\ShuffledMatches.txt")
   
    End Sub
   
   
    Sub PopulatePlayers()
       
            Players(1) = "Andy"
            Players(2) = "Brian"
            Players(3) = "Claire"
            Players(4) = "Derek"
            Players(5) = "Edward"
            Players(6) = "Fred"
            Players(7) = "Gerry"
            Players(8) = "Hannah"
            Players(9) = "Isabel"
            Players(10) = "Jim"
       
    End Sub
   
    Sub GenerateMatches()
   
        Match = 0
       
        For Player1 = 1 To 10               'LOOP THROUGH PLAYERS
       
            For Player2 = 1 To 10           'LOOP THROUGH PLAYERS
           
                Match = Match + 1           'INCREMENT MATCHES
           
                If Player2 = Player1 Then Player2 = Player2 + 1
                                            'PLAYER CANNOT PLAY HIMSELF
                If Player2 > 10 Then Exit For
                                            'NOT MORE THAN TEN PLAYERS
               
                Matches(Match) = Players(Player1) & " v " & Players(Player2)
                                            'ADD MATCH TO ARRAY
               
            Next Player2
           
        Next Player1
   
    End Sub
   
   
    Sub ShuffleMatches()
   
        For Shuffles = 1 To 10
               
            For Counter = 1 To 90
           
                Randomize Timer
               
                tempStr = Matches(Counter)
                tempInt = Int(Rnd * 90) + 1
               
                Matches(Counter) = Matches(tempInt)
                Matches(tempInt) = tempStr  'SHUFFLE MATCHES
           
            Next Counter
           
        Next Shuffles
   
    End Sub
   
   
    Sub OutputMatches(FileName As String)
   
        Open FileName For Output As #1
       
            For Counter = 1 To 90
           
                Print #1, Matches(Counter)
               
            Next Counter
           
        Close #1
       
    End Sub

HTH

J

Thanks great J,
But i need the to schedule the results in fixtures i.e
 Fixture 1
player 1 vs player 2
player3 vs player 4
player 5 vs player 6
player 7 vs player 8
player 9 vs player 10

Fixture 2
player 1 vs player 3
player 2 vs player 4
player 5 vs player 7
player 6 vs player 10
player 9 vs player 8

fixture 3
etc......

Regars,

Munzi

The quickest way is to say each fixture consists of 5 random matches, changing OutputMatches as follows:

    Sub OutputMatches(FileName As String)

        Fixture = 0
   
        Open FileName For Output As #1
       
            For Counter = 1 To 90
           
                  If (Counter - 1) / 5 = (Counter - 1) \ 5 Then
                       Fixture = Fixture + 1
                       Print #1, vbCrLf & "Fixture " & Fixture
                  End If

                  Print #1, Matches(Counter)
               
            Next Counter
           
        Close #1
       
    End Sub

But if everyone has to play on every day, you'll need something more complicated...

J.

Thans J,

But unfortunatly i need everyone to play on the same day, my appologies for not making this clear earlier.

Regards,

Munzi

Then I don't think random matches are your best solution.  Will try to generate a formula...

J.

Thans J.....
look forward to your answer.

Is this a real life thing?  

It's just you have 90 matches to get played on one pool table in one day?  

Average game of pool - 10mins maybe longer?

900mins of pool = 15 hours pool!

Still an interesting problem ;)

ummm thats what i thought when i got told this first ;o)
Yes, its a real life situation,

there is going to be 1 fixture per day and everyone must play in each fixture.....

Try this:
Create a new project. Place a list box and a command button: List1 and Command1 respectively. Place the following code in it. Run it and press the button. The code should work with any number of players but I am not certain about the fixture headers if an odd number of players was selected.

The initial array building could be made more efficient - I get 90 matches, then jettison half of them and then double the 45 matches, reversing the latter 45's homes and aways.



Option Explicit
Private Players() As String
Private PlayerNames As String

Private Sub Command1_Click()
    Players = Split(PlayerNames, ",")
    ShufflePlayers
    Play
End Sub

Private Sub Form_Load()
    Randomize (Timer)
    PlayerNames = "Alice,Bob,Charlie,Dave,Eddie,Freda,George,Harry,Ian,Jack"
End Sub

Private Sub ShufflePlayers()
    Dim lPlayers() As String
    Dim i As Long
    Dim j As Long
    Dim r As Long
   
    ReDim lPlayers(UBound(Players))
   
    For i = 0 To UBound(Players)
        r = Fix(Rnd * UBound(Players))
        Do Until lPlayers(r) = vbNullString
            r = IIf(r < UBound(Players), r + 1, 0)
        Loop
        lPlayers(r) = Players(i)
    Next
   
    Players = lPlayers
End Sub

Private Sub Play()
    Dim i As Long
    Dim j As Long
    Dim u As Long
    Dim p As Long
    Dim m1() As Long
    Dim m2() As Long
    Dim t As Long
    Dim c As Long
    Dim c2 As Long
    Dim f As Long

    List1.Clear

    u = UBound(Players)
    p = u + 1
   
    ReDim m1(p ^ 2 - (p + 1), 1)
   
    For i = 1 To p
        For j = 0 To u
            t = IIf(j + i < p, j + i, j + i - p)
            If j <> t Then
                m1(c, 0) = j
                m1(c, 1) = t
                c = c + 1
               
            End If
        Next
    Next

    c = p \ 2

    For i = 0 To 1
        For j = 0 To UBound(m1, 1) Step 2
            c = c + 1
            If c >= p \ 2 Then
                f = f + 1
                List1.AddItem "Fixture " & f
                c = 0
            End If
            If f And 1 Then
                List1.AddItem "     " & Players(m1(j, 0)) & "  v  " & Players(m1(j, 1))
            Else
                List1.AddItem "     " & Players(m1(j, 1)) & "  v  " & Players(m1(j, 0))
            End If
        Next
    Next
       
End Sub

You don't need c2 or m2 variables in it - delete them. I accidentally left them there when I tried something else.

Nope, no joy; I don't have my math hat on today...

Well I've just tested my solution. It keels over (expectedly) if you give it one name or no names.Otherwise it appears to work for any number of names at least up to 40 (158 fixtures of 20 matches each). If you give it an odd number, one person sits out each of the fixtures.

Well I tested it again. I was wrong - how embarassing. It's close but not quite. I'll have to work out that first bit properly.

fds_fatboy,

Thanks for trying...i have tested it wih four players and it does not seem to work, as you have alreay mentioned....any ideas?

J.....have you got your maths hat on today?

Regards,

Munzi

No, I can get it so far, using bitwise logic and it will generate 90 matches, where everyone plays everyone twice but I can't get it to do it so that everyone plays on the same day.

J.

I tried a brute force approach and I think it 'should' work.  Basically it will create a random Fixture of 5 matches but then reject it if anyone has played before.  Since you want two matches per 'couple' the theory works OK since P1 vs P2 is one match and P2 vs P1 is the other.

Unfortunately I doubt it could ever solve it fully since the probability keeps getting harder!

Am trying to think how to cross breed this approach with an ordered selection but ...

Start a blank Excel workbook, add a module and paste the code.  It will work with the activesheet (and it will blank it!)

The progress (fixtures found) is shown on the statusbar

Public Sub Matches()

    Dim iL      As Integer
    Dim iR1     As Integer
    Dim iR2     As Integer
    Dim bP(10)  As Boolean
    Dim iRow    As Integer
    Dim iBack   As Integer
    Dim bSame   As Boolean
   
    Application.ScreenUpdating = False
   
    ActiveSheet.Cells.ClearContents
   
    iRow = 1
    While iRow <= 90
   
        For iL = 1 To 5
       
            iR1 = Int(10 * Rnd + 1)
            While bP(iR1)
                iR1 = Int(10 * Rnd + 1)
            Wend
            bP(iR1) = True
           
            iR2 = Int(10 * Rnd + 1)
            While bP(iR2) Or iR1 = iR2
                iR2 = Int(10 * Rnd + 1)
            Wend
            bP(iR2) = True
   
            ActiveSheet.Cells(iRow, iL).Value = iR1 & " vs " & iR2
           
        Next
       
        With ActiveSheet.Range(ActiveSheet.Cells(iRow, 1), ActiveSheet.Cells(iRow, 2))
                 
            If iRow > 1 Then
           
                For iBack = iRow - 1 To 1 Step -1
                    bSame = False
                    For iL = 1 To 5
                        If Application.WorksheetFunction.CountIf(ActiveSheet.Range("A1:E100"), ActiveSheet.Cells(iRow, iL).Value) > 1 Then
                            bSame = True
                            Exit For
                        End If
                    Next
                    If bSame Then
                        .ClearContents
                        iRow = iRow - 1
                        Exit For
                    End If
                Next
           
            End If
           
        End With
       
        For iL = 1 To 10
            bP(iL) = False
        Next
               
        iRow = iRow + 1
        Application.StatusBar = iRow
       
    Wend
   
    Application.ScreenUpdating = True
   
End Sub

Thanks lads, both solutions work.

Munzi