# 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. ## 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. ## 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. ## 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
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

4. ## 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

Originally Posted by 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
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
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. ## 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
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 !!

6. ## Re: Trying to pair names randomly into teams??

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

Mike

Originally Posted by 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.
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
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 First 123

#### Posting Permissions

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