Want to win a PS4? Go Premium and enter to win our High-Tech Treats giveaway. Enter to Win

x
?
Solved

All posible sequences of 10 playes - URGENT

Posted on 2004-11-01
21
Medium Priority
?
236 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
Comment
Question by:munzi79
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 7
  • 6
  • 5
  • +1
21 Comments
 
LVL 5

Expert Comment

by:RogueSolutions
ID: 12461592
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
ID: 12461981
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
ID: 12462173
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
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

Author Comment

by:munzi79
ID: 12462274
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
ID: 12462329
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
ID: 12462469
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
ID: 12462675
Then I don't think random matches are your best solution.  Will try to generate a formula...

J.
0
 

Author Comment

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

Expert Comment

by:RogueSolutions
ID: 12462866

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
ID: 12462985
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
ID: 12463053
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
ID: 12463083
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
ID: 12463182
Nope, no joy; I don't have my math hat on today...
0
 
LVL 10

Expert Comment

by:fds_fatboy
ID: 12463450
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
ID: 12464201
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
ID: 12471231
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
ID: 12473267
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
ID: 12473870
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
jimbobmcgee earned 300 total points
ID: 12474672
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:
fds_fatboy earned 450 total points
ID: 12476197
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
ID: 12484613
Thanks lads, both solutions work.

Munzi
0

Featured Post

Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

The debugging module of the VB 6 IDE can be accessed by way of the Debug menu item. That menu item can normally be found in the IDE's main menu line as shown in this picture.   There is also a companion Debug Toolbar that looks like the followin…
Article by: Martin
Here are a few simple, working, games that you can use as-is or as the basis for your own games. Tic-Tac-Toe This is one of the simplest of all games.   The game allows for a choice of who goes first and keeps track of the number of wins for…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…
Suggested Courses

610 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