Page 3 of 3 FirstFirst 123
Results 21 to 26 of 26

Trying to pair names randomly into teams??

This is a discussion on Trying to pair names randomly into teams?? within the Excel Questions forums, part of the Question Forums category; MickG.... One last scenerio. Is there an easy way to pair two or more players together if they need to ...

  1. #21
    New Member
    Join Date
    Jan 2008
    Posts
    13

    Default Re: Trying to pair names randomly into teams??

    MickG....

    One last scenerio.

    Is there an easy way to pair two or more players together if they need to be together within this code?

    Lets say ****, Bob, and Larry need to play together in a list of 33 players. Is there a way, lets say, if I put a " * " by their name, they will be on the same team in a three some or even a four some?


    Thanks again!!

    Mike

  2. #22
    MrExcel MVP
    Join Date
    Aug 2004
    Location
    Tokyo, Japan
    Posts
    16,995

    Default Re: Trying to pair names randomly into teams??

    typo
    Code:
        Sum_3 = Choose((UBound(a,1) Mod 4) + 1, 0,3,2,1)
    should be
    Code:
        Sume_3 = Choose((UBound(a,1) Mod 4) + 1, 0,3,2,1)

  3. #23
    Board Regular
    Join Date
    Jan 2008
    Posts
    8,129

    Default Re: Trying to pair names randomly into teams??

    Hi, Mike try this:-
    Paste this code in a new CommandBar on "Golfers Names" Sheet.
    First run the first code I sent you to get the random NumbersList. The list should now be in Column "C".

    In column "A" select the names you want to Pair ( Min 1 Pair Max 4),colour those cells "Yellow" (Interior.indexNumber = 6)
    Run this new code:- The Selected names (Coloured Yellow)
    should now appear at the top of the list in column "C".
    If you want to Select more pairs, cancel the yellow cells in column "A".
    Reselect new pairs ,run the code again .The new selection should appear under the previous selection
    NB:- All these "Paired" cells in Column "C" will be coloured yellow.
    NB:- All the new paired cells should lie in Groups within the previously
    Grouped cells
    See how it goes
    Code:
    Dim cl As Range, oNm As Range, Spn(), c As Integer
    c = 0
    For Each oNm In Range(Range("A1"), Range("A" & Rows.count).End(xlUp))
     If oNm.Interior.ColorIndex = 6 Then
        ReDim Preserve Spn(c)
           Spn(c) = oNm.Value
              c = c + 1
            End If
     Next oNm
    
    If c < 2 Or c > 4 Then
       MsgBox "Number selected ouside limit - Try Again"
         Exit Sub
    End If
    
    Dim oTemp, oPst
    
    For Each cl In Range(Range("c1"), Range("c" & Rows.count).End(xlUp))
        If cl.Offset(c - 1).Interior.ColorIndex = cl.Interior.ColorIndex _
            And Not cl.Interior.ColorIndex = 6 Then
                oPst = cl.Address
                    oTemp = cl.Resize(c).Value
                        Exit For
                    End If
                Next cl
    
    Dim oSel, oSwap
    For oSel = 0 To UBound(Spn())
        For Each oSwap In Range(Range("c1"), Range("c" & Rows.count).End(xlUp))
            If oSwap = Spn(oSel) Then
                    oSwap.Value = oTemp(oSel + 1, 1)
                End If
            Next oSwap
        Next oSel
    Range(oPst).Resize(c).Value = Application.Transpose(Spn)
    Range(oPst).Resize(c).Interior.ColorIndex = 6
    Regards Mick
    Last edited by MickG; Jun 17th, 2008 at 01:02 PM.

  4. #24
    New Member
    Join Date
    Jan 2008
    Posts
    13

    Default Re: Trying to pair names randomly into teams??

    Hi MickG...

    When I run this code, I get "Number selected outside limit - try again" on the spreadsheet page? .... and it dosen't let me do anything else.

    Is it possible to get the "selected yellow names" to run at the bottom of the list instead of the top of the list?

    Again, THANK YOU! You are saving me a huge amount of work!

    Mike




    Quote Originally Posted by MickG View Post
    Hi, Mike try this:-
    Paste this code in a new CommandBar on "Golfers Names" Sheet.
    First run the first code I sent you to get the random NumbersList. The list should now be in Column "C".

    In column "A" select the names you want to Pair ( Min 1 Pair Max 4),colour those cells "Yellow" (Interior.indexNumber = 6)
    Run this new code:- The Selected names (Coloured Yellow)
    should now appear at the top of the list in column "C".
    If you want to Select more pairs, cancel the yellow cells in column "A".
    Reselect new pairs ,run the code again .The new selection should appear under the previous selection
    NB:- All these "Paired" cells in Column "C" will be coloured yellow.
    NB:- All the new paired cells should lie in Groups within the previously
    Grouped cells
    See how it goes
    Code:
    Dim cl As Range, oNm As Range, Spn(), c As Integer
    c = 0
    For Each oNm In Range(Range("A1"), Range("A" & Rows.count).End(xlUp))
     If oNm.Interior.ColorIndex = 6 Then
        ReDim Preserve Spn(c)
           Spn(c) = oNm.Value
              c = c + 1
            End If
     Next oNm
    
    If c < 2 Or c > 4 Then
       MsgBox "Number selected ouside limit - Try Again"
         Exit Sub
    End If
    
    Dim oTemp, oPst
    
    For Each cl In Range(Range("c1"), Range("c" & Rows.count).End(xlUp))
        If cl.Offset(c - 1).Interior.ColorIndex = cl.Interior.ColorIndex _
            And Not cl.Interior.ColorIndex = 6 Then
                oPst = cl.Address
                    oTemp = cl.Resize(c).Value
                        Exit For
                    End If
                Next cl
    
    Dim oSel, oSwap
    For oSel = 0 To UBound(Spn())
        For Each oSwap In Range(Range("c1"), Range("c" & Rows.count).End(xlUp))
            If oSwap = Spn(oSel) Then
                    oSwap.Value = oTemp(oSel + 1, 1)
                End If
            Next oSwap
        Next oSel
    Range(oPst).Resize(c).Value = Application.Transpose(Spn)
    Range(oPst).Resize(c).Interior.ColorIndex = 6
    Regards Mick

  5. #25
    Board Regular
    Join Date
    Jan 2008
    Posts
    8,129

    Default Re: Trying to pair names randomly into teams??

    Hi Mike, I've now change things a bit.
    Instead of colouring the special "Names" cells yellow, I've changed the Selection option to highlighting the Names in "BOLD" font. I think it will be less confusing.
    The first thing to do is add the following line to the original code , Just above the words "End Sub". This line will Reset the font "BOLD" property to False (Normal Font) For Column "A". and Column "C". This will happen each time a new "Names" Randomization list is formed..
    This will enable you to have a clean slate at the beginning of each new List.
    Code:
    Range("C1").Resize(RanRng.count).Font.Bold = False
    RanRng.Font.Bold = False
    Now replace the last bit of code (In the Golfers Names sheet) I sent you with this new code..

    Recap:- How to use this new bit of code.
    Players names in Column "A"
    Run first code.
    Randomized List of Players names Grouped in Fours and Threes By colour now appears in column "C".
    Procedure to Group special Players:-
    Groups must be a Min of 2 and a Max. of 4 .
    Change the font for the .selected players in Column "A" to "BOLD"
    Example:- The names of three players in Column "A" are changed to "BOLD" Font.
    Run the Second Code "Special players".
    The three players selected will now bee seen at the Bottom of the List in column "C" in "Bold".
    The Players that were originally there have now Changed places.

    NB:- If you had selected "Four" Players and the Last group in column "C" consisted of only "Three cells" The Four player would be places in the first Available "Four Slot" starting from the Bottom.. The code will Always select the correct slot size starting from the Bottom.

    If you now wish to enter another group of Special Names in the same Random List.
    Select those names again from Column "A" (Obviously none of the previous special names).
    Run the code again.
    The New Special Players will be added to the First available slot above (or Below) the previous "Special player" at the bottom of Column "C".
    NB:- If you select too many or too few the code will tell you (as you already found out) The code will be exited and the "Bold" fonts in column "A" will be reset to normal.
    Code:
    Dim cl As Range, oNm As Range, Spn(), c As Integer, rng As Range
    c = 0
    Set rng = Range(Range("A1"), Range("A" & Rows.count).End(xlUp))
    For Each oNm In rng
     If oNm.Font.Bold = True Then
        ReDim Preserve Spn(c)
           Spn(c) = oNm.Value
              c = c + 1
            End If
     Next oNm
    
    If c < 2 Or c > 4 Then
       MsgBox "Number selected ouside limit " & vbNewLine _
       & "         (Min 2 Max 4)" & vbNewLine & vbNewLine _
       & """Please Reselect Names (BOLD) """
         rng.Font.Bold = False
         Exit Sub
    End If
    
    Dim oTemp, oPst
    
    For Each cl In Range(Range("c1"), Range("c" & Rows.count).End(xlUp))
        If cl.Offset(c - 1).Interior.ColorIndex = cl.Interior.ColorIndex _
            And Not cl.Offset(c - 1).Font.Bold = True Then
                oPst = cl.Address
                    oTemp = cl.Resize(c).Value
                        'Exit For
                    End If
                Next cl
    MsgBox oPst
    
    
    Dim oSel, oSwap
    For oSel = 0 To UBound(Spn())
        For Each oSwap In Range(Range("c1"), Range("c" & Rows.count).End(xlUp))
            If oSwap = Spn(oSel) Then
                oSwap.Value = oTemp(oSel + 1, 1)
                End If
    Next oSwap
    Next oSel
    Range(oPst).Resize(c).Value = Application.Transpose(Spn)
    Range(oPst).Resize(c).Font.Bold = True
    rng.Font.Bold = False
    Regards Mick
    PS - I Hope I'm getting a plaque on the clubhouse wall !!
    Last edited by MickG; Jun 18th, 2008 at 07:00 AM.

  6. #26
    New Member
    Join Date
    Jan 2008
    Posts
    13

    Default Re: Trying to pair names randomly into teams??

    This is EXACTLY want I wanted!!! Thank you, Thank you!!!

    Mike

    Quote Originally Posted by MickG View Post
    Hi Mike, I've now change things a bit.
    Instead of colouring the special "Names" cells yellow, I've changed the Selection option to highlighting the Names in "BOLD" font. I think it will be less confusing.
    The first thing to do is add the following line to the original code , Just above the words "End Sub". This line will Reset the font "BOLD" property to False (Normal Font) For Column "A". and Column "C". This will happen each time a new "Names" Randomization list is formed..
    This will enable you to have a clean slate at the beginning of each new List.
    Code:
    Range("C1").Resize(RanRng.count).Font.Bold = False
    RanRng.Font.Bold = False
    Now replace the last bit of code (In the Golfers Names sheet) I sent you with this new code..

    Recap:- How to use this new bit of code.
    Players names in Column "A"
    Run first code.
    Randomized List of Players names Grouped in Fours and Threes By colour now appears in column "C".
    Procedure to Group special Players:-
    Groups must be a Min of 2 and a Max. of 4 .
    Change the font for the .selected players in Column "A" to "BOLD"
    Example:- The names of three players in Column "A" are changed to "BOLD" Font.
    Run the Second Code "Special players".
    The three players selected will now bee seen at the Bottom of the List in column "C" in "Bold".
    The Players that were originally there have now Changed places.

    NB:- If you had selected "Four" Players and the Last group in column "C" consisted of only "Three cells" The Four player would be places in the first Available "Four Slot" starting from the Bottom.. The code will Always select the correct slot size starting from the Bottom.

    If you now wish to enter another group of Special Names in the same Random List.
    Select those names again from Column "A" (Obviously none of the previous special names).
    Run the code again.
    The New Special Players will be added to the First available slot above (or Below) the previous "Special player" at the bottom of Column "C".
    NB:- If you select too many or too few the code will tell you (as you already found out) The code will be exited and the "Bold" fonts in column "A" will be reset to normal.
    Code:
    Dim cl As Range, oNm As Range, Spn(), c As Integer, rng As Range
    c = 0
    Set rng = Range(Range("A1"), Range("A" & Rows.count).End(xlUp))
    For Each oNm In rng
     If oNm.Font.Bold = True Then
        ReDim Preserve Spn(c)
           Spn(c) = oNm.Value
              c = c + 1
            End If
     Next oNm
    
    If c < 2 Or c > 4 Then
       MsgBox "Number selected ouside limit " & vbNewLine _
       & "         (Min 2 Max 4)" & vbNewLine & vbNewLine _
       & """Please Reselect Names (BOLD) """
         rng.Font.Bold = False
         Exit Sub
    End If
    
    Dim oTemp, oPst
    
    For Each cl In Range(Range("c1"), Range("c" & Rows.count).End(xlUp))
        If cl.Offset(c - 1).Interior.ColorIndex = cl.Interior.ColorIndex _
            And Not cl.Offset(c - 1).Font.Bold = True Then
                oPst = cl.Address
                    oTemp = cl.Resize(c).Value
                        'Exit For
                    End If
                Next cl
    MsgBox oPst
    
    
    Dim oSel, oSwap
    For oSel = 0 To UBound(Spn())
        For Each oSwap In Range(Range("c1"), Range("c" & Rows.count).End(xlUp))
            If oSwap = Spn(oSel) Then
                oSwap.Value = oTemp(oSel + 1, 1)
                End If
    Next oSwap
    Next oSel
    Range(oPst).Resize(c).Value = Application.Transpose(Spn)
    Range(oPst).Resize(c).Font.Bold = True
    rng.Font.Bold = False
    Regards Mick
    PS - I Hope I'm getting a plaque on the clubhouse wall !!

Page 3 of 3 FirstFirst 123

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  


DMCA.com