Solved

All posible sequences of 10 playes - URGENT

Posted on 2004-11-01
226 Views
Last Modified: 2010-05-02
Hi Experts,
This is probably realy easy but its monday and my heads not working. Here is what i need to achieve;

There are 10 player and they need to play eash other twice in a game of pool hoe can i do a program which randomly selects the payers and makes sure each player has played everyone else?
This needs to be done in VB6 or and Excel spreadsheet.

Regards,

Munzi
0
Question by:munzi79
    21 Comments
     
    LVL 5

    Expert Comment

    by:RogueSolutions
    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)?


    0
     

    Author Comment

    by:munzi79
    Sorry RogueSolutions,

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

    Expert Comment

    by:jimbobmcgee
    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
    0
     

    Author Comment

    by:munzi79
    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
    0
     
    LVL 16

    Expert Comment

    by:jimbobmcgee
    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.
    0
     

    Author Comment

    by:munzi79
    Thans J,

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

    Regards,

    Munzi
    0
     
    LVL 16

    Expert Comment

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

    J.
    0
     

    Author Comment

    by:munzi79
    Thans J.....
    look forward to your answer.
    0
     
    LVL 5

    Expert Comment

    by:RogueSolutions

    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 ;)


    0
     

    Author Comment

    by:munzi79
    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.....
    0
     
    LVL 10

    Expert Comment

    by:fds_fatboy
    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
    0
     
    LVL 10

    Expert Comment

    by:fds_fatboy
    You don't need c2 or m2 variables in it - delete them. I accidentally left them there when I tried something else.
    0
     
    LVL 16

    Expert Comment

    by:jimbobmcgee
    Nope, no joy; I don't have my math hat on today...
    0
     
    LVL 10

    Expert Comment

    by:fds_fatboy
    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.
    0
     
    LVL 10

    Expert Comment

    by:fds_fatboy
    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.
    0
     

    Author Comment

    by:munzi79
    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
    0
     
    LVL 16

    Expert Comment

    by:jimbobmcgee
    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.
    0
     
    LVL 5

    Expert Comment

    by:RogueSolutions
    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

    0
     
    LVL 16

    Assisted Solution

    by:jimbobmcgee
    I've got a brute-force method that definately works; it just keeps generating files until it gets it right (usually in less than 500 attempts -- its quite quick really)

    It's based on the bitwise thing I was trying earlier.  The problem I was having was that the logic was able to make sure that a player did not have two matches in the same fixture, but it couldn't force it to create fixtures where everybody played.  

    It's all to do with the order in which the match list is passed to the sorting function; only certain orders work.  So I created a brute force system, with a randomizer, that just keeps going until it hits a suitable sequence.

    It should work for any array of players, even or odd, but gets a bit slow around the 20-mark.  You might have to start it off, go away and come back, as the more players used, the longer it will take.  

    Here goes:

        Public Type FixtureType
            Name        As String
            Value       As Long
            DeleteMe    As Boolean
        End Type
       
        Public Players()        As FixtureType
        Public Matches()        As FixtureType
        Public SavedMatches()   As FixtureType
       
        Public Everyone         As Long
        Public DebugCount       As Long
        Public TargetFixtures   As Long
        Public ActualFixtures   As Long
       
        Private Sub GetPlayerNames()
           
            ReDim Players(1 To 10) As FixtureType   'NOTE: MANUALLY SET UP PLAYER ARRAY
                                                    '      WITH THE RIGHT SIZE!!
            Players(1).Name = "Andy"
            Players(2).Name = "Brian"
            Players(3).Name = "Claire"
            Players(4).Name = "Derek"
            Players(5).Name = "Edward"
            Players(6).Name = "Fred"
            Players(7).Name = "Gerry"
            Players(8).Name = "Hannah"
            Players(9).Name = "Isabel"
            Players(10).Name = "Jim"
               
        End Sub
       
       
        Private Sub AssignPlayerValues()
       
            'CREATE BITWISE VALUES FOR EACH PLAYER
            '   E.G.    1000000000 FOR PLAYER 1 = &H200 = 512
            '           0000000001 FOR PLAYER 2 = &H100 = 256
            '           0100000000 FOR PLAYER 3 = &H80  = 128
            '           0000000010 FOR PLAYER 4 = &H40  = 64
            '           ETC
           
            Everyone = 0
             
            For i = LBound(Players()) To UBound(Players())
           
                Players(i).Value = 2 ^ (((UBound(Players()) + 1) - i) - 1)
                Everyone = Everyone + Players(i).Value
               
            Next i
       
        End Sub
       
       
        Private Sub GenerateMatches()
           
            'USE LOGICAL OR TO CREATE A NUMBER FOR EACH MATCH, BASED ON THE
            'VALUES FOR EACH PLAYER PLAYING
            '   E.G.    PLAYER 1 v PLAYER 2 = 1100000000 = &H300 = 768
            '           PLAYER 3 v PLAYER 4 = 0011000000 = &HC0  = 192
            '           PLAYER 2 v PLAYER 1 = 1100000000 = &H300 = 768
           
            Dim MatchCount As Long
           
            MatchCount = 0
            For Plr1 = LBound(Players()) To UBound(Players())
                For Plr2 = LBound(Players()) To UBound(Players())
                    If Plr2 = Plr1 Then Plr2 = Plr2 + 1
                    If Plr2 > UBound(Players()) Then Exit For
                    MatchCount = MatchCount + 1
                Next Plr2
            Next Plr1
           
            ReDim SavedMatches(1 To MatchCount) As FixtureType
           
            MatchCount = 0
            For Plr1 = LBound(Players()) To UBound(Players())
                For Plr2 = LBound(Players()) To UBound(Players())
               
                    If Plr2 = Plr1 Then Plr2 = Plr2 + 1
                    If Plr2 > UBound(Players()) Then Exit For
                    MatchCount = MatchCount + 1
                   
                    SavedMatches(MatchCount).Name = Players(Plr1).Name & " v " & Players(Plr2).Name
                    SavedMatches(MatchCount).Value = Players(Plr1).Value Or Players(Plr2).Value
                    SavedMatches(MatchCount).DeleteMe = False
                   
                Next Plr2
            Next Plr1
           
            TargetFixtures = (UBound(SavedMatches()) / (UBound(Players()) / 2)) + _
                    (2 * Abs(CInt(Not (UBound(Players()) \ 2) = (UBound(Players()) / 2))))
           
        End Sub
       
       
        Private Sub ShuffleMatches()
       
            'RANDOMIZER AND SHUFFLER, FOR BRUTE FORCE METHOD
       
            Dim tmpMatch As FixtureType
                   
                For Counter = 1 To UBound(Matches())
               
                    Randomize Timer
                   
                    tmpMatch.Name = Matches(Counter).Name
                    tmpMatch.Value = Matches(Counter).Value
                    tmpMatch.DeleteMe = Matches(Counter).DeleteMe
                   
                    tempInt = Int(Rnd * UBound(Matches())) + 1
                   
                    Matches(Counter).Name = Matches(tempInt).Name
                    Matches(Counter).Value = Matches(tempInt).Value
                    Matches(Counter).DeleteMe = Matches(tempInt).DeleteMe
                   
                    Matches(tempInt).Name = tmpMatch.Name
                    Matches(tempInt).Value = tmpMatch.Value
                    Matches(tempInt).DeleteMe = tmpMatch.DeleteMe
                                                            'SHUFFLE MATCHES
               
                Next Counter
       
        End Sub
       
       
        Private Sub SortMatches(FileName As String)
       
            'RUN THROUGH MATCHES ASSIGNING TO FIXTURE, OUTPUTTING TO FILENAME
       
            Dim MatchMask   As Long
            Dim Fixtures    As Long
            Dim Count       As Long
           
            ActualFixtures = 1
            Count = 0
       
            Open FileName For Output As #1
               
                Do Until UpdateMatchList = 0
               
                    MatchMask = 0
                    Print #1, "Fixture " & ActualFixtures
                   
                        For i = LBound(Matches()) To UBound(Matches())
                            Matches(i).DeleteMe = False
                        Next i
               
                        For i = LBound(Matches()) To UBound(Matches())
                       
                            If MatchMask = Everyone Then Exit For
                           
                            If (Matches(i).Value And MatchMask) = 0 Then
                           
                                MatchMask = (MatchMask Or Matches(i).Value)
                                Matches(i).DeleteMe = True
       
                                Print #1, Matches(i).Name & vbTab & _
                                          Matches(i).Value & vbTab & _
                                          MatchMask & vbTab;
                                       
                                For z = UBound(Players()) To LBound(Players()) Step -1
                                    Print #1, CStr(Abs(CInt((MatchMask And Players(z).Value) <> 0)));
                                Next z
                                Print #1, ""
                               
                                Count = Count + 1
                       
                            End If
                           
                        Next i
                   
                    ActualFixtures = ActualFixtures + 1
                    Print #1, ""
                   
                Loop
               
                Print #1, vbCrLf & "Matches: " & Count
               
            Close #1
       
        End Sub
       
       
        Private Function UpdateMatchList() As Long
       
            'REMOVE ASSIGNED MATCHES FROM MATCH LIST, SO THEY CANNOT BE USED AGAIN
           
            Dim tmpMatches() As FixtureType
            Dim MatchCount As Long
            tmpMatches() = Matches()
       
            MatchCount = 0
           
            For i = LBound(tmpMatches()) To UBound(tmpMatches())
                If tmpMatches(i).DeleteMe = False Then MatchCount = MatchCount + 1
            Next i
       
            UpdateMatchList = MatchCount
            If MatchCount = 0 Then Exit Function
               
            ReDim Matches(1 To MatchCount) As FixtureType
           
            MatchCount = 0
            For i = LBound(tmpMatches()) To UBound(tmpMatches())
                If tmpMatches(i).DeleteMe = False Then
                    MatchCount = MatchCount + 1
                    Matches(MatchCount).Name = tmpMatches(i).Name
                    Matches(MatchCount).Value = tmpMatches(i).Value
                    Matches(MatchCount).DeleteMe = False
                End If
            Next i
       
            Call ShuffleMatches
       
        End Function
       
       
        Private Sub Main()
           
            Attempts = 0            'RESET ATTEMPTS COUNTER
            ActualFixtures = 0      'RESET FIXTURES COUNT
             
            Call GetPlayerNames
            Call AssignPlayerValues
            Call GenerateMatches
           
            Debug.Print "Target Fixtures: " & TargetFixtures
           
            Do Until ActualFixtures - 1 = TargetFixtures    'BRUTE FORCE LOOP UNTIL SOLVED
               
                Attempts = Attempts + 1
                Debug.Print "Attempt #" & Attempts & ": ";    'SHOW STATUS IN DEBUG WINDOW
                Matches() = SavedMatches()       'COPY MATCH LIST TO WORKING LIST, TO SAVE TIME
                SortMatches "c:\fixattempts\fixtures." & Format(Attempts, "00000") & ".txt"
                                    'SAVE ATTEMPT TO FILE, BASED ON CURRENT ATTEMPT NUMBER
                Debug.Print "Fixtures=" & ActualFixtures - 1  'SHOW STATUS IN DEBUG WINDOW
               
            Loop
           
            MsgBox "Generation completed in " & Attempts & " attempts."     'SHOW RESULTS
       
        End Sub

    Good luck!!

    HTH

    J.
    0
     
    LVL 10

    Accepted Solution

    by:
    Yes, but look at this:
    Not as efficient as it could be (it could be improved) but not all brute force:
    Same scenario as before: Form with a list box and command button. It runs with any number over 1 including odds:

    Option Explicit
    Dim PlayerNames As String
    Dim Players() As String
    Dim blnOdd As Boolean

    Private Sub Command1_Click()
        Command1.Enabled = False
        ShufflePlayers
        Play
        Command1.Enabled = True
    End Sub

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

        Players = Split(PlayerNames, ",")
        If Not UBound(Players) And 1 Then
            Players = Split(PlayerNames & ",", ",")
            blnOdd = True
        End If
    End Sub

    Private Sub ShufflePlayers()
        Dim lPlayers() As String
        Dim i As Long
        Dim j As Long
        Dim r As Long
        Dim u As Long
       
        u = UBound(Players) + blnOdd

        ReDim lPlayers(UBound(Players))

        For i = 0 To u
            r = Fix(Rnd * u)
            Do Until lPlayers(r) = vbNullString
                r = IIf(r < u, r + 1, 0)
            Loop
            lPlayers(r) = Players(i)
        Next

        Players = lPlayers
    End Sub

    Private Sub Play()
        Dim i As Long, j As Long, c As Long, t As Long
        Dim u As Long, p As Long
        Dim m() As Long, pm() As Long
        Dim mc As Long
        Dim mf As Long, mb As Boolean, mfs As Long
        Dim m2() As Long

        List1.Clear

        u = UBound(Players)
        p = u + 1

        ReDim m(0 To (p ^ 2 - p) - 1, 2)
        ReDim pm(0 To u)

        For i = 1 To p
            For j = 0 To u Step 2
                t = IIf(j + i < p, j + i, j + i - p)
                If j <> t Then
                    m(c, 0) = j
                    m(c, 1) = t
                    c = c + 1
                   
                End If
            Next
            For j = 1 To u Step 2
                t = IIf(j + i < p, j + i, j + i - p)
                If j <> t Then
                    m(c, 0) = j
                    m(c, 1) = t
                    c = c + 1
                   
                End If
            Next
        Next

        For i = 0 To 2 * u - 1
            DoEvents
            List1.AddItem "Fixture " & i + 1
            mf = -1

            Do
                DoEvents
                mc = 0
                mb = False

                mfs = mf
                For j = mfs + 1 To UBound(m)
                    If mc >= p \ 2 Then
                        Exit For
                    End If
                    If m(j, 2) = 0 And pm(m(j, 0)) <= i And pm(m(j, 1)) <= i Then
                        If Not mb Then
                            mb = True
                            mf = j
                        End If
                        m(j, 2) = -1
                        mc = mc + 1
                        pm(m(j, 0)) = i + 1
                        pm(m(j, 1)) = i + 1
                    End If
                Next

                For j = 0 To mfs
                    If mc >= p \ 2 Then
                        Exit For
                    End If
                    If m(j, 2) = 0 And pm(m(j, 0)) <= i And pm(m(j, 1)) <= i Then
                        If Not mb Then
                            mf = j
                        End If
                        m(j, 2) = -1
                        mc = mc + 1
                        pm(m(j, 0)) = i + 1
                        pm(m(j, 1)) = i + 1
                    End If
                Next

                If mc < p \ 2 Then
                    For j = 0 To UBound(m, 1)
                        If m(j, 2) = -1 Then
                            m(j, 2) = 0
                            pm(m(j, 0)) = i
                            pm(m(j, 1)) = i
                        End If
                    Next
                    If mf = UBound(m) Then
                        ShuffleMatches m
                    End If
                End If
       
            Loop Until mc >= p \ 2

            If UBound(m, 1) > mc Then
                ReDim m2(UBound(m, 1) - mc, 2)
            Else
                ReDim m2(UBound(m, 1), 2)
            End If

            c = 0
            For j = 0 To UBound(m)
                If m(j, 2) = -1 Then
                    If Not (blnOdd And (m(j, 0) = u Or m(j, 1) = u)) Then
                        List1.AddItem "     " & Players(m(j, 0)) & "  v  " & Players(m(j, 1))
                    End If
                Else
                    m2(c, 0) = m(j, 0)
                    m2(c, 1) = m(j, 1)
                    m2(c, 2) = 0
                    c = c + 1
                End If
            Next
            m = m2
        Next
    End Sub

    Private Sub ShuffleMatches(ByRef m1() As Long)
        Dim m2() As Long
       
        Dim i As Long
        Dim j As Long
        Dim r As Long
        Dim u As Long
       
        u = UBound(m1, 1)
       
        ReDim m2(u, 2)
       
        For i = 0 To u
            r = Fix(Rnd * u)
            Do Until (m2(r, 0) Or m2(r, 1)) = 0
                r = IIf(r < u, r + 1, 0)
            Loop
            m2(r, 0) = m1(i, 0)
            m2(r, 1) = m1(i, 1)
            m2(r, 2) = m1(i, 2)
        Next
       
        m1 = m2
    End Sub
       
    0
     

    Author Comment

    by:munzi79
    Thanks lads, both solutions work.

    Munzi
    0

    Write Comment

    Please enter a first name

    Please enter a last name

    We will never share this with anyone.

    Featured Post

    IT, Stop Being Called Into Every Meeting

    Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

    I’ve seen a number of people looking for examples of how to access web services from VB6.  I’ve been using a test harness I built in VB6 (using many resources I found online) that I use for small projects to work out how to communicate with web serv…
    Have you ever wanted to restrict the users input in a textbox to numbers, and while doing that make sure that they can't 'cheat' by pasting in non-numeric text? Of course you can do that with code you write yourself but it's tedious and error-prone …
    Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
    Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

    846 members asked questions and received personalized solutions in the past 7 days.

    Join the community of 500,000 technology professionals and ask your questions.

    Join & Ask a Question

    Need Help in Real-Time?

    Connect with top rated Experts

    5 Experts available now in Live!

    Get 1:1 Help Now