Trying to pair names randomly into teams??

[poop91407]

First off, I'm a novice at excel.

I need some help. I work at a golf course.
At work, I need to randomly pair players together to form teams.

For example:
Saturday morning, there are 19 golfers signed up to play together, but want to paired randomly.

This is what we currently do:
In cells A1:A27 I type their names. In B1:B27, I type their handicaps.

We then use a deck of cards to randomly draw teams. We do this by pulling 4-A's, 4-k's, 4-Q's, 4-J's, and 3-10's from the deck. We shuffle these cards and then go down the names in colum A and assign each palyer a card and place the card value into column C. We then highlight all three columns and sort by column C to form teams.

This works ok, but the problem is they all tee off at the same time and need a "super quick" process to form teams in seconds.

The only variable that I might see being a problem is the # of players vary each time they play. There might be 12 one day and 51 the next. We have to form teams into 4 somes and 3 somes, based on the total number of players we get.

Any help appreciated... The easier the better!! Thanks!

 

[poop91407]

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

 

[jindon]

typo

    Sum_3 = Choose((UBound(a,1) Mod 4) + 1, 0,3,2,1)

should be

    Sume_3 = Choose((UBound(a,1) Mod 4) + 1, 0,3,2,1)

 

[MickG]

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

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

 

[poop91407]

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

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

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

 

[MickG]

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.

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.

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 !!

 

[poop91407]

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

Mike

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.

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.

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 !!

 

[Matt5353]

Hi Mike came across your thread by chance.
I have no idea what or when I came into your lengthy debate on trying to resolve the issues that have come but this will do for now.
I believe I came across this in the early stages of the discussion.
I downloaded your early vba and it works great but I get a error in the code when I go to protect the sheet but this will do for now.
How can I fix the error when I go to protect the sheet because I do not want that every time you touch a cell it changes the initial draw.
if I do the draw I do not want it to change by accident.
Andrew.
Hopefully you have enough imfo but glad to catch up and fix this.

 

[Matt5353]

Hi Mick Thanks for this.
Works fine. I have changed the it from fours to pairs but I want to protect the sheet so that everytime you enter a cell it does not change the draw you have just done. There is an error in the code RanRag.offset(,20).ClearContents.
Is there a way to fix this so i can protect the sheet. I have added a "push button only" to use on the spreadsheet to make it more dynamic so when you do the draw visibly people can see that it is done without manipulating the draw.

 

[MickG]

Which code are you using ??
Rather than protecting the sheet ??, perhaps you could add the "Worksheet_Change" event to the worksheet module.
This will clear column 3 if you try to add more players to column "A", after you have run the First code.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Rngc As Range
Set Rng = Range("A1", Range("A" & Rows.Count).End(xlUp))
Set Rngc = Range("C1", Range("C" & Rows.Count).End(xlUp))
If Rng.Count > Rngc.Count Then
  Range("C:C").ClearContents
End If
End Sub

 

[MickG]

This might be a better option for both codes.
Players start "A2", H'caps in "B" Results in "C".
You can place both codes in Active Worksheet Module.

[COLOR="Navy"]Sub[/COLOR] MG03Dec10
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] rNum [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Num [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nn [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] oCol [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))

[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
oCol = 34
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
  .Item(Dn.Value) = Empty
    [COLOR="Navy"]If[/COLOR] Dn.Row Mod 2 = 0 And oCol = 34 [COLOR="Navy"]Then[/COLOR]
        oCol = 35
    [COLOR="Navy"]ElseIf[/COLOR] Dn.Row Mod 2 = 0 And oCol = 35 [COLOR="Navy"]Then[/COLOR]
        oCol = 34
   [COLOR="Navy"]End[/COLOR] If
   Dn.Resize(, 3).Interior.ColorIndex = oCol
[COLOR="Navy"]Next[/COLOR]

Num = .Count
[COLOR="Navy"]Do[/COLOR] Until c = Num
    nn = Application.RandBetween(1, Num)
        [COLOR="Navy"]If[/COLOR] .exists(Cells(nn + 1, "A").Value) [COLOR="Navy"]Then[/COLOR]
            c = c + 1
            Cells(c + 1, "C") = Cells(nn, "A")
            .Remove Cells(nn + 1, "A").Value
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Loop[/COLOR]
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]




Private [COLOR="Navy"]Sub[/COLOR] Worksheet_Change(ByVal Target [COLOR="Navy"]As[/COLOR] Range)
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Rngc [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range("A1", Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]Set[/COLOR] Rngc = Range("C1", Range("C" & Rows.Count).End(xlUp))
[COLOR="Navy"]If[/COLOR] Not Intersect(Target, Columns("A:A")) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
    Application.EnableEvents = False
        [COLOR="Navy"]If[/COLOR] Rng.Count > Rngc.Count [COLOR="Navy"]Then[/COLOR]
            Range("C:C").ClearContents
            Range("C1").Value = "Pair [COLOR="Navy"]With[/COLOR] ??"
        [COLOR="Navy"]End[/COLOR] If
    Application.EnableEvents = True

[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]


[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick