I am trying to randomize numbers for a dart tournament. I have 3 categories
Masters would draw cards first (a random number half of the total dart
players) then draw ladies (a random number half of the total dart players)
then men the remaining cards.

Master1 = 5 Lady1 = 2 MAn1 = 3
Master2 = 2 Lady2 = 3 Man2 = 1
Lady3 = 1 Man3 = 5
Lady4 = 4 Man4 = 4

Thanks in advance for your help!

The data you posted and your description don't agree so it is difficult to
produce the code you need. Also the Man column seems to be missing the
number 2.

I think you just need to assign a random numbers to each category and then
sort these numbers. There arre 2 Masters, so assign a random number between
1 and 2 to each Master. There arre 4 Ladies, so assign a Random number
between 1 and 4 to each Lady. There are 4 men, so assign a random number
between 1 and 4 to each man.
"Sean" wrote:

I am trying to randomize numbers for a dart tournament. I have 3 categories
Masters would draw cards first (a random number half of the total dart
players) then draw ladies (a random number half of the total dart players)
then men the remaining cards.

Master1 = 5 Lady1 = 2 MAn1 = 3
Master2 = 2 Lady2 = 3 Man2 = 1
Lady3 = 1 Man3 = 5
Lady4 = 4 Man4 = 4

Thanks in advance for your help!

there would be a total of 10 players master1 and man3 got a 5 so they would
be partnered up together. it is very confusing, the three categories will
not have the same number of players. a master could be a woman or a man it is
someone who has a certain average in our league. the ladies have secon draw
so the have a better chance of matching up with a master, then the men draw
the remaining cards(numbers). I hope this explains a little better.

"Joel" wrote:

The data you posted and your description don't agree so it is difficult to
produce the code you need. Also the Man column seems to be missing the
number 2.

I think you just need to assign a random numbers to each category and then
sort these numbers. There arre 2 Masters, so assign a random number between
1 and 2 to each Master. There arre 4 Ladies, so assign a Random number
between 1 and 4 to each Lady. There are 4 men, so assign a random number
between 1 and 4 to each man.
"Sean" wrote:

I am trying to randomize numbers for a dart tournament. I have 3 categories
Masters would draw cards first (a random number half of the total dart
players) then draw ladies (a random number half of the total dart players)
then men the remaining cards.

Master1 = 5 Lady1 = 2 MAn1 = 3
Master2 = 2 Lady2 = 3 Man2 = 1
Lady3 = 1 Man3 = 5
Lady4 = 4 Man4 = 4

Thanks in advance for your help!

This is a little complicated. Will finish tonight.

"Sean" wrote:

there would be a total of 10 players master1 and man3 got a 5 so they would
be partnered up together. it is very confusing, the three categories will
not have the same number of players. a master could be a woman or a man it is
someone who has a certain average in our league. the ladies have secon draw
so the have a better chance of matching up with a master, then the men draw
the remaining cards(numbers). I hope this explains a little better.

"Joel" wrote:

The data you posted and your description don't agree so it is difficult to
produce the code you need. Also the Man column seems to be missing the
number 2.

I think you just need to assign a random numbers to each category and then
sort these numbers. There arre 2 Masters, so assign a random number between
1 and 2 to each Master. There arre 4 Ladies, so assign a Random number
between 1 and 4 to each Lady. There are 4 men, so assign a random number
between 1 and 4 to each man.
"Sean" wrote:

I am trying to randomize numbers for a dart tournament. I have 3 categories
Masters would draw cards first (a random number half of the total dart
players) then draw ladies (a random number half of the total dart players)
then men the remaining cards.

Master1 = 5 Lady1 = 2 MAn1 = 3
Master2 = 2 Lady2 = 3 Man2 = 1
Lady3 = 1 Man3 = 5
Lady4 = 4 Man4 = 4

Thanks in advance for your help!

I did the paring up a little different than described, but the result is the
the same probability.

'enter Names stating in Row 1
'enter Masters in Column A
'enter Ladies in Column B
'enter Men in Column C
'Teams will be in Column E, F, G

I always list masters in the order given.
Unique Random Numbers from the same list are given to men and woman starting
1 and going to the total number of combined men and woman. The lowest
numbers are assigned a master.

If you have 4 men and 4 women and 2 masters. I have each woman pick a
unique random number from 1 to 8 (total men and woman). If they chose a
number already picked the choose again until a unique number is given to each
woman. The woman who aren't assigned a master get to pick a second time.
They throw in there old number before picking a new number.

Next the men pick the ramaining numbers the woman haven't drawn. Then I
sort the woman by the random numbers they picked and I do the same thing for
the men.

If there arre two masters the person who go random number 1 is assigned to
master 1 and the person who got random number 2 is assined master 2. the
remaining men and woman are paired based on the random number chosen. The
lowest number man is paired with the lowest number woman. The next highest
man is paired with the next highest woman.

Sub make_Teams()
'Constants used to reference Array
Const PersonName = 0
Const RanNumber = 1
'enter Names stating in Row 1
'enter Masters in Column A
'enter Ladies in Column B
'enter Men in Column C
'Teams will be in Column E, F, G
Dim LadyMen(20, 2)

'clear old results
Range("E1:G20").ClearContents

NumberMasters = Cells(Rows.Count, "A").End(xlUp).Row
NumberLadies = Cells(Rows.Count, "B").End(xlUp).Row
NumberMen = Cells(Rows.Count, "C").End(xlUp).Row

TotalLadymen = NumberLadies + NumberMen

'Copy Masters to Team columns
Columns("A:A").Copy Destination:=Columns("E:E")

'Add Lady and men to array
ArrayCount = 0
For i = 1 To NumberLadies
LadyMen(i - 1, PersonName) = Cells(i, "B")
Next i
For i = 1 To NumberMen
LadyMen(NumberLadies + i - 1, PersonName) = Cells(i, "C")
Next i

'give two chances for women to match up with Master
For i = 1 To 2
For j = 0 To (NumberLadies - 1)
'check if lady is already paired with master
If i = 2 Then
'Random number starts at 0
If LadyMen(k, RanNumber) < NumberMasters Then
'Lady is already paired with master
PairedwithMaster = True
End If
Else
PairedwithMaster = False
End If
'get unique number not already drawn
If PairedwithMaster = False Then
LadyMen(k, RanNumber) = ""
Do
Found = False
NewNumber = Int(TotalLadymen * Rnd()) + 1
For k = 0 To (NumberLadies - 1)
If NewNumber = LadyMen(k, RanNumber) Then
Found = True
Exit For
End If
Next k
Loop While (Found = True)
LadyMen(j, RanNumber) = NewNumber
End If
Next j
Next i

'assign random number to men
For j = NumberLadies To (TotalLadymen - 1)
'get unique number not already drawn
Do
Found = False
NewNumber = Int(TotalLadymen * Rnd()) + 1
For k = 0 To (TotalLadymen - 1)
If NewNumber = LadyMen(k, RanNumber) Then
Found = True
Exit For
End If
Next k
Loop While (Found = True)
LadyMen(j, RanNumber) = NewNumber
Next j
'sort ladies then men
For i = 0 To (NumberLadies - 2)
For j = i To (NumberLadies - 1)
If LadyMen(i, RanNumber) LadyMen(j, RanNumber) Then
temp = LadyMen(i, RanNumber)
LadyMen(i, RanNumber) = LadyMen(j, RanNumber)
LadyMen(j, RanNumber) = temp

temp = LadyMen(i, PersonName)
LadyMen(i, PersonName) = LadyMen(j, PersonName)
LadyMen(j, PersonName) = temp
End If
Next j
Next i
For i = NumberLadies To (TotalLadymen - 2)
For j = i To (TotalLadymen - 1)
If LadyMen(i, RanNumber) LadyMen(j, RanNumber) Then
temp = LadyMen(i, RanNumber)
LadyMen(i, RanNumber) = LadyMen(j, RanNumber)
LadyMen(j, RanNumber) = temp

temp = LadyMen(i, PersonName)
LadyMen(i, PersonName) = LadyMen(j, PersonName)
LadyMen(j, PersonName) = temp
End If
Next j
Next i

'Place Names in Teams columns
'first ladies
RowCount = NumberMasters + 1
For i = 0 To (NumberLadies - 1)
If LadyMen(i, RanNumber) <= NumberMasters Then
Cells(LadyMen(i, RanNumber), "F") = LadyMen(i, PersonName)
Else
Cells(RowCount, "F") = LadyMen(i, PersonName)
RowCount = RowCount + 1
End If
Next i
'now men
RowCount = NumberMasters + 1
For i = NumberLadies To (TotalLadymen - 1)
If LadyMen(i, RanNumber) <= NumberMasters Then
Cells(LadyMen(i, RanNumber), "G") = LadyMen(i, PersonName)
Else
Cells(RowCount, "G") = LadyMen(i, PersonName)
RowCount = RowCount + 1
End If
Next i

'Place
End Sub


"Joel" wrote:

This is a little complicated. Will finish tonight.

"Sean" wrote:

there would be a total of 10 players master1 and man3 got a 5 so they would
be partnered up together. it is very confusing, the three categories will
not have the same number of players. a master could be a woman or a man it is
someone who has a certain average in our league. the ladies have secon draw
so the have a better chance of matching up with a master, then the men draw
the remaining cards(numbers). I hope this explains a little better.

"Joel" wrote:

The data you posted and your description don't agree so it is difficult to
produce the code you need. Also the Man column seems to be missing the
number 2.

I think you just need to assign a random numbers to each category and then
sort these numbers. There arre 2 Masters, so assign a random number between
1 and 2 to each Master. There arre 4 Ladies, so assign a Random number
between 1 and 4 to each Lady. There are 4 men, so assign a random number
between 1 and 4 to each man.
"Sean" wrote:

I am trying to randomize numbers for a dart tournament. I have 3 categories
Masters would draw cards first (a random number half of the total dart
players) then draw ladies (a random number half of the total dart players)
then men the remaining cards.

Master1 = 5 Lady1 = 2 MAn1 = 3
Master2 = 2 Lady2 = 3 Man2 = 1
Lady3 = 1 Man3 = 5
Lady4 = 4 Man4 = 4

Thanks in advance for your help!

Sean: I noticed that the women were not getting matched with masters more
often with men. I wrote some simulation code and found out I was corect.
Each were only getting 50%. found a couple of bugs in my code in the area
where the women were picking random number twice. The new code with 4
ladies, 4 men and 2 master now has the women paired with masters 75% and the
men with masters only 25%.

Here is the new code and the simulation code

Sub make_Teams()
'Constants used to reference Array
Const PersonName = 0
Const RanNumber = 1
'enter Names stating in Row 1
'enter Masters in Column A
'enter Ladies in Column B
'enter Men in Column C
'Teams will be in Column E, F, G
Dim LadyMen(20, 2)

'clear old results
Range("E1:G20").ClearContents

NumberMasters = Cells(Rows.Count, "A").End(xlUp).Row
NumberLadies = Cells(Rows.Count, "B").End(xlUp).Row
NumberMen = Cells(Rows.Count, "C").End(xlUp).Row

TotalLadymen = NumberLadies + NumberMen

'Copy Masters to Team columns
Columns("A:A").Copy Destination:=Columns("E:E")

'Add Lady and men to array
ArrayCount = 0
For i = 1 To NumberLadies
LadyMen(i - 1, PersonName) = Cells(i, "B")
Next i
For i = 1 To NumberMen
LadyMen(NumberLadies + i - 1, PersonName) = Cells(i, "C")
Next i

'give two chances for women to match up with Master
For i = 1 To 2
For j = 0 To (NumberLadies - 1)
'check if lady is already paired with master
PairedwithMaster = False
If i = 2 Then
'Random number starts at 0
If LadyMen(j, RanNumber) <= NumberMasters Then
'Lady is already paired with master
PairedwithMaster = True
End If
End If
'get unique number not already drawn
If PairedwithMaster = False Then
LadyMen(j, RanNumber) = 0
Do
Found = False
NewNumber = Int(TotalLadymen * Rnd()) + 1
For k = 0 To (NumberLadies - 1)
If NewNumber = LadyMen(k, RanNumber) Then
Found = True
Exit For
End If
Next k
Loop While (Found = True)
LadyMen(j, RanNumber) = NewNumber
End If
Next j
Next i

'assign random number to men
For j = NumberLadies To (TotalLadymen - 1)
'get unique number not already drawn
Do
Found = False
NewNumber = Int(TotalLadymen * Rnd()) + 1
For k = 0 To (TotalLadymen - 1)
If NewNumber = LadyMen(k, RanNumber) Then
Found = True
Exit For
End If
Next k
Loop While (Found = True)
LadyMen(j, RanNumber) = NewNumber
Next j
'sort ladies then men
For i = 0 To (NumberLadies - 2)
For j = i To (NumberLadies - 1)
If LadyMen(i, RanNumber) LadyMen(j, RanNumber) Then
temp = LadyMen(i, RanNumber)
LadyMen(i, RanNumber) = LadyMen(j, RanNumber)
LadyMen(j, RanNumber) = temp

temp = LadyMen(i, PersonName)
LadyMen(i, PersonName) = LadyMen(j, PersonName)
LadyMen(j, PersonName) = temp
End If
Next j
Next i
For i = NumberLadies To (TotalLadymen - 2)
For j = i To (TotalLadymen - 1)
If LadyMen(i, RanNumber) LadyMen(j, RanNumber) Then
temp = LadyMen(i, RanNumber)
LadyMen(i, RanNumber) = LadyMen(j, RanNumber)
LadyMen(j, RanNumber) = temp

temp = LadyMen(i, PersonName)
LadyMen(i, PersonName) = LadyMen(j, PersonName)
LadyMen(j, PersonName) = temp
End If
Next j
Next i

'Place Names in Teams columns
'first ladies
RowCount = NumberMasters + 1
For i = 0 To (NumberLadies - 1)
If LadyMen(i, RanNumber) <= NumberMasters Then
Cells(LadyMen(i, RanNumber), "F") = LadyMen(i, PersonName)
Else
Cells(RowCount, "F") = LadyMen(i, PersonName)
RowCount = RowCount + 1
End If
Next i
'now men
RowCount = NumberMasters + 1
For i = NumberLadies To (TotalLadymen - 1)
If LadyMen(i, RanNumber) <= NumberMasters Then
Cells(LadyMen(i, RanNumber), "G") = LadyMen(i, PersonName)
Else
Cells(RowCount, "G") = LadyMen(i, PersonName)
RowCount = RowCount + 1
End If
Next i

'Place
End Sub
Sub simulate()

NumberMasters = Cells(Rows.Count, "A").End(xlUp).Row
Ladywithmaster = 0
Menwithmaster = 0

For i = 1 To 1000
Call make_Teams
Ladywithmaster = WorksheetFunction. _
CountA(Range("F1:F" & NumberMasters)) + Ladywithmaster
Menwithmaster = WorksheetFunction. _
CountA(Range("G1:G" & NumberMasters)) + Menwithmaster
Next i
percentlady = 100 * (Ladywithmaster / 2000#)
percentmen = 100 * (Menwithmaster / 2000#)
MsgBox ("Percent Ladies paired with Masters = " & percentlady & _
Chr(13) & "Percent Men Paired with Masters = " & percentmen)
End Sub


"Joel" wrote:

I did the paring up a little different than described, but the result is the
the same probability.

'enter Names stating in Row 1
'enter Masters in Column A
'enter Ladies in Column B
'enter Men in Column C
'Teams will be in Column E, F, G

I always list masters in the order given.
Unique Random Numbers from the same list are given to men and woman starting
1 and going to the total number of combined men and woman. The lowest
numbers are assigned a master.

If you have 4 men and 4 women and 2 masters. I have each woman pick a
unique random number from 1 to 8 (total men and woman). If they chose a
number already picked the choose again until a unique number is given to each
woman. The woman who aren't assigned a master get to pick a second time.
They throw in there old number before picking a new number.

Next the men pick the ramaining numbers the woman haven't drawn. Then I
sort the woman by the random numbers they picked and I do the same thing for
the men.

If there arre two masters the person who go random number 1 is assigned to
master 1 and the person who got random number 2 is assined master 2. the
remaining men and woman are paired based on the random number chosen. The
lowest number man is paired with the lowest number woman. The next highest
man is paired with the next highest woman.

Sub make_Teams()
'Constants used to reference Array
Const PersonName = 0
Const RanNumber = 1
'enter Names stating in Row 1
'enter Masters in Column A
'enter Ladies in Column B
'enter Men in Column C
'Teams will be in Column E, F, G
Dim LadyMen(20, 2)

'clear old results
Range("E1:G20").ClearContents

NumberMasters = Cells(Rows.Count, "A").End(xlUp).Row
NumberLadies = Cells(Rows.Count, "B").End(xlUp).Row
NumberMen = Cells(Rows.Count, "C").End(xlUp).Row

TotalLadymen = NumberLadies + NumberMen

'Copy Masters to Team columns
Columns("A:A").Copy Destination:=Columns("E:E")

'Add Lady and men to array
ArrayCount = 0
For i = 1 To NumberLadies
LadyMen(i - 1, PersonName) = Cells(i, "B")
Next i
For i = 1 To NumberMen
LadyMen(NumberLadies + i - 1, PersonName) = Cells(i, "C")
Next i

'give two chances for women to match up with Master
For i = 1 To 2
For j = 0 To (NumberLadies - 1)
'check if lady is already paired with master
If i = 2 Then
'Random number starts at 0
If LadyMen(k, RanNumber) < NumberMasters Then
'Lady is already paired with master
PairedwithMaster = True
End If
Else
PairedwithMaster = False
End If
'get unique number not already drawn
If PairedwithMaster = False Then
LadyMen(k, RanNumber) = ""
Do
Found = False
NewNumber = Int(TotalLadymen * Rnd()) + 1
For k = 0 To (NumberLadies - 1)
If NewNumber = LadyMen(k, RanNumber) Then
Found = True
Exit For
End If
Next k
Loop While (Found = True)
LadyMen(j, RanNumber) = NewNumber
End If
Next j
Next i

'assign random number to men
For j = NumberLadies To (TotalLadymen - 1)
'get unique number not already drawn
Do
Found = False
NewNumber = Int(TotalLadymen * Rnd()) + 1
For k = 0 To (TotalLadymen - 1)
If NewNumber = LadyMen(k, RanNumber) Then
Found = True
Exit For
End If
Next k
Loop While (Found = True)
LadyMen(j, RanNumber) = NewNumber
Next j
'sort ladies then men
For i = 0 To (NumberLadies - 2)
For j = i To (NumberLadies - 1)
If LadyMen(i, RanNumber) LadyMen(j, RanNumber) Then
temp = LadyMen(i, RanNumber)
LadyMen(i, RanNumber) = LadyMen(j, RanNumber)
LadyMen(j, RanNumber) = temp

temp = LadyMen(i, PersonName)
LadyMen(i, PersonName) = LadyMen(j, PersonName)
LadyMen(j, PersonName) = temp
End If
Next j
Next i
For i = NumberLadies To (TotalLadymen - 2)
For j = i To (TotalLadymen - 1)
If LadyMen(i, RanNumber) LadyMen(j, RanNumber) Then
temp = LadyMen(i, RanNumber)
LadyMen(i, RanNumber) = LadyMen(j, RanNumber)
LadyMen(j, RanNumber) = temp

temp = LadyMen(i, PersonName)
LadyMen(i, PersonName) = LadyMen(j, PersonName)
LadyMen(j, PersonName) = temp
End If
Next j
Next i

'Place Names in Teams columns
'first ladies
RowCount = NumberMasters + 1
For i = 0 To (NumberLadies - 1)
If LadyMen(i, RanNumber) <= NumberMasters Then
Cells(LadyMen(i, RanNumber), "F") = LadyMen(i, PersonName)
Else
Cells(RowCount, "F") = LadyMen(i, PersonName)
RowCount = RowCount + 1
End If
Next i
'now men
RowCount = NumberMasters + 1
For i = NumberLadies To (TotalLadymen - 1)
If LadyMen(i, RanNumber) <= NumberMasters Then
Cells(LadyMen(i, RanNumber), "G") = LadyMen(i, PersonName)
Else
Cells(RowCount, "G") = LadyMen(i, PersonName)
RowCount = RowCount + 1
End If
Next i

'Place
End Sub


"Joel" wrote:

This is a little complicated. Will finish tonight.

"Sean" wrote:

there would be a total of 10 players master1 and man3 got a 5 so they would
be partnered up together. it is very confusing, the three categories will
not have the same number of players. a master could be a woman or a man it is
someone who has a certain average in our league. the ladies have secon draw
so the have a better chance of matching up with a master, then the men draw
the remaining cards(numbers). I hope this explains a little better.

"Joel" wrote:

The data you posted and your description don't agree so it is difficult to
produce the code you need. Also the Man column seems to be missing the
number 2.

I think you just need to assign a random numbers to each category and then
sort these numbers. There arre 2 Masters, so assign a random number between
1 and 2 to each Master. There arre 4 Ladies, so assign a Random number
between 1 and 4 to each Lady. There are 4 men, so assign a random number
between 1 and 4 to each man.
"Sean" wrote:

I am trying to randomize numbers for a dart tournament. I have 3 categories
Masters would draw cards first (a random number half of the total dart
players) then draw ladies (a random number half of the total dart players)
then men the remaining cards.

Master1 = 5 Lady1 = 2 MAn1 = 3
Master2 = 2 Lady2 = 3 Man2 = 1
Lady3 = 1 Man3 = 5
Lady4 = 4 Man4 = 4

Thanks in advance for your help!

Joel,

Thank you for your help I am going to tr it Saturday Night a the tournament.
I may have a few more questions for you. Thank you!!!!! This will save
about 20min. every saturday night.



"Joel" wrote:

Sean: I noticed that the women were not getting matched with masters more
often with men. I wrote some simulation code and found out I was corect.
Each were only getting 50%. found a couple of bugs in my code in the area
where the women were picking random number twice. The new code with 4
ladies, 4 men and 2 master now has the women paired with masters 75% and the
men with masters only 25%.

Here is the new code and the simulation code

Sub make_Teams()
'Constants used to reference Array
Const PersonName = 0
Const RanNumber = 1
'enter Names stating in Row 1
'enter Masters in Column A
'enter Ladies in Column B
'enter Men in Column C
'Teams will be in Column E, F, G
Dim LadyMen(20, 2)

'clear old results
Range("E1:G20").ClearContents

NumberMasters = Cells(Rows.Count, "A").End(xlUp).Row
NumberLadies = Cells(Rows.Count, "B").End(xlUp).Row
NumberMen = Cells(Rows.Count, "C").End(xlUp).Row

TotalLadymen = NumberLadies + NumberMen

'Copy Masters to Team columns
Columns("A:A").Copy Destination:=Columns("E:E")

'Add Lady and men to array
ArrayCount = 0
For i = 1 To NumberLadies
LadyMen(i - 1, PersonName) = Cells(i, "B")
Next i
For i = 1 To NumberMen
LadyMen(NumberLadies + i - 1, PersonName) = Cells(i, "C")
Next i

'give two chances for women to match up with Master
For i = 1 To 2
For j = 0 To (NumberLadies - 1)
'check if lady is already paired with master
PairedwithMaster = False
If i = 2 Then
'Random number starts at 0
If LadyMen(j, RanNumber) <= NumberMasters Then
'Lady is already paired with master
PairedwithMaster = True
End If
End If
'get unique number not already drawn
If PairedwithMaster = False Then
LadyMen(j, RanNumber) = 0
Do
Found = False
NewNumber = Int(TotalLadymen * Rnd()) + 1
For k = 0 To (NumberLadies - 1)
If NewNumber = LadyMen(k, RanNumber) Then
Found = True
Exit For
End If
Next k
Loop While (Found = True)
LadyMen(j, RanNumber) = NewNumber
End If
Next j
Next i

'assign random number to men
For j = NumberLadies To (TotalLadymen - 1)
'get unique number not already drawn
Do
Found = False
NewNumber = Int(TotalLadymen * Rnd()) + 1
For k = 0 To (TotalLadymen - 1)
If NewNumber = LadyMen(k, RanNumber) Then
Found = True
Exit For
End If
Next k
Loop While (Found = True)
LadyMen(j, RanNumber) = NewNumber
Next j
'sort ladies then men
For i = 0 To (NumberLadies - 2)
For j = i To (NumberLadies - 1)
If LadyMen(i, RanNumber) LadyMen(j, RanNumber) Then
temp = LadyMen(i, RanNumber)
LadyMen(i, RanNumber) = LadyMen(j, RanNumber)
LadyMen(j, RanNumber) = temp

temp = LadyMen(i, PersonName)
LadyMen(i, PersonName) = LadyMen(j, PersonName)
LadyMen(j, PersonName) = temp
End If
Next j
Next i
For i = NumberLadies To (TotalLadymen - 2)
For j = i To (TotalLadymen - 1)
If LadyMen(i, RanNumber) LadyMen(j, RanNumber) Then
temp = LadyMen(i, RanNumber)
LadyMen(i, RanNumber) = LadyMen(j, RanNumber)
LadyMen(j, RanNumber) = temp

temp = LadyMen(i, PersonName)
LadyMen(i, PersonName) = LadyMen(j, PersonName)
LadyMen(j, PersonName) = temp
End If
Next j
Next i

'Place Names in Teams columns
'first ladies
RowCount = NumberMasters + 1
For i = 0 To (NumberLadies - 1)
If LadyMen(i, RanNumber) <= NumberMasters Then
Cells(LadyMen(i, RanNumber), "F") = LadyMen(i, PersonName)
Else
Cells(RowCount, "F") = LadyMen(i, PersonName)
RowCount = RowCount + 1
End If
Next i
'now men
RowCount = NumberMasters + 1
For i = NumberLadies To (TotalLadymen - 1)
If LadyMen(i, RanNumber) <= NumberMasters Then
Cells(LadyMen(i, RanNumber), "G") = LadyMen(i, PersonName)
Else
Cells(RowCount, "G") = LadyMen(i, PersonName)
RowCount = RowCount + 1
End If
Next i

'Place
End Sub
Sub simulate()

NumberMasters = Cells(Rows.Count, "A").End(xlUp).Row
Ladywithmaster = 0
Menwithmaster = 0

For i = 1 To 1000
Call make_Teams
Ladywithmaster = WorksheetFunction. _
CountA(Range("F1:F" & NumberMasters)) + Ladywithmaster
Menwithmaster = WorksheetFunction. _
CountA(Range("G1:G" & NumberMasters)) + Menwithmaster
Next i
percentlady = 100 * (Ladywithmaster / 2000#)
percentmen = 100 * (Menwithmaster / 2000#)
MsgBox ("Percent Ladies paired with Masters = " & percentlady & _
Chr(13) & "Percent Men Paired with Masters = " & percentmen)
End Sub


"Joel" wrote:

I did the paring up a little different than described, but the result is the
the same probability.

'enter Names stating in Row 1
'enter Masters in Column A
'enter Ladies in Column B
'enter Men in Column C
'Teams will be in Column E, F, G

I always list masters in the order given.
Unique Random Numbers from the same list are given to men and woman starting
1 and going to the total number of combined men and woman. The lowest
numbers are assigned a master.

If you have 4 men and 4 women and 2 masters. I have each woman pick a
unique random number from 1 to 8 (total men and woman). If they chose a
number already picked the choose again until a unique number is given to each
woman. The woman who aren't assigned a master get to pick a second time.
They throw in there old number before picking a new number.

Next the men pick the ramaining numbers the woman haven't drawn. Then I
sort the woman by the random numbers they picked and I do the same thing for
the men.

If there arre two masters the person who go random number 1 is assigned to
master 1 and the person who got random number 2 is assined master 2. the
remaining men and woman are paired based on the random number chosen. The
lowest number man is paired with the lowest number woman. The next highest
man is paired with the next highest woman.

Sub make_Teams()
'Constants used to reference Array
Const PersonName = 0
Const RanNumber = 1
'enter Names stating in Row 1
'enter Masters in Column A
'enter Ladies in Column B
'enter Men in Column C
'Teams will be in Column E, F, G
Dim LadyMen(20, 2)

'clear old results
Range("E1:G20").ClearContents

NumberMasters = Cells(Rows.Count, "A").End(xlUp).Row
NumberLadies = Cells(Rows.Count, "B").End(xlUp).Row
NumberMen = Cells(Rows.Count, "C").End(xlUp).Row

TotalLadymen = NumberLadies + NumberMen

'Copy Masters to Team columns
Columns("A:A").Copy Destination:=Columns("E:E")

'Add Lady and men to array
ArrayCount = 0
For i = 1 To NumberLadies
LadyMen(i - 1, PersonName) = Cells(i, "B")
Next i
For i = 1 To NumberMen
LadyMen(NumberLadies + i - 1, PersonName) = Cells(i, "C")
Next i

'give two chances for women to match up with Master
For i = 1 To 2
For j = 0 To (NumberLadies - 1)
'check if lady is already paired with master
If i = 2 Then
'Random number starts at 0
If LadyMen(k, RanNumber) < NumberMasters Then
'Lady is already paired with master
PairedwithMaster = True
End If
Else
PairedwithMaster = False
End If
'get unique number not already drawn
If PairedwithMaster = False Then
LadyMen(k, RanNumber) = ""
Do
Found = False
NewNumber = Int(TotalLadymen * Rnd()) + 1
For k = 0 To (NumberLadies - 1)
If NewNumber = LadyMen(k, RanNumber) Then
Found = True
Exit For
End If
Next k
Loop While (Found = True)
LadyMen(j, RanNumber) = NewNumber
End If
Next j
Next i

'assign random number to men
For j = NumberLadies To (TotalLadymen - 1)
'get unique number not already drawn
Do
Found = False
NewNumber = Int(TotalLadymen * Rnd()) + 1
For k = 0 To (TotalLadymen - 1)
If NewNumber = LadyMen(k, RanNumber) Then
Found = True
Exit For
End If
Next k
Loop While (Found = True)
LadyMen(j, RanNumber) = NewNumber
Next j
'sort ladies then men
For i = 0 To (NumberLadies - 2)
For j = i To (NumberLadies - 1)
If LadyMen(i, RanNumber) LadyMen(j, RanNumber) Then
temp = LadyMen(i, RanNumber)
LadyMen(i, RanNumber) = LadyMen(j, RanNumber)
LadyMen(j, RanNumber) = temp

temp = LadyMen(i, PersonName)
LadyMen(i, PersonName) = LadyMen(j, PersonName)
LadyMen(j, PersonName) = temp
End If
Next j
Next i
For i = NumberLadies To (TotalLadymen - 2)
For j = i To (TotalLadymen - 1)
If LadyMen(i, RanNumber) LadyMen(j, RanNumber) Then
temp = LadyMen(i, RanNumber)
LadyMen(i, RanNumber) = LadyMen(j, RanNumber)
LadyMen(j, RanNumber) = temp

temp = LadyMen(i, PersonName)
LadyMen(i, PersonName) = LadyMen(j, PersonName)
LadyMen(j, PersonName) = temp
End If
Next j
Next i

'Place Names in Teams columns
'first ladies
RowCount = NumberMasters + 1
For i = 0 To (NumberLadies - 1)

Ifixed the simulate function. It was dividing by the wrong number when you
didn't have 2 masters. the percentage Ladies get paired with masters will
vary depending on the number of women and masters. Women havve a big
advantagge in your game!


Sub simulate()
Const Trials As Single = 1000
NumberMasters = Cells(Rows.Count, "A").End(xlUp).Row
Ladywithmaster = 0
Menwithmaster = 0

For i = 1 To Trials
Call make_Teams
Ladywithmaster = WorksheetFunction. _
CountA(Range("F1:F" & NumberMasters)) + Ladywithmaster
Menwithmaster = WorksheetFunction. _
CountA(Range("G1:G" & NumberMasters)) + Menwithmaster
Next i
percentlady = 100# * (Ladywithmaster / _
(NumberMasters * Trials))
percentmen = 100# * (Menwithmaster / _
(NumberMasters * Trials))
MsgBox ("Percent Ladies paired with Masters = " & percentlady & _
Chr(13) & "Percent Men Paired with Masters = " & percentmen)
End Sub

"Sean" wrote:

Joel,

Thank you for your help I am going to tr it Saturday Night a the tournament.
I may have a few more questions for you. Thank you!!!!! This will save
about 20min. every saturday night.



"Joel" wrote:

Sean: I noticed that the women were not getting matched with masters more
often with men. I wrote some simulation code and found out I was corect.
Each were only getting 50%. found a couple of bugs in my code in the area
where the women were picking random number twice. The new code with 4
ladies, 4 men and 2 master now has the women paired with masters 75% and the
men with masters only 25%.

Here is the new code and the simulation code

Sub make_Teams()
'Constants used to reference Array
Const PersonName = 0
Const RanNumber = 1
'enter Names stating in Row 1
'enter Masters in Column A
'enter Ladies in Column B
'enter Men in Column C
'Teams will be in Column E, F, G
Dim LadyMen(20, 2)

'clear old results
Range("E1:G20").ClearContents

NumberMasters = Cells(Rows.Count, "A").End(xlUp).Row
NumberLadies = Cells(Rows.Count, "B").End(xlUp).Row
NumberMen = Cells(Rows.Count, "C").End(xlUp).Row

TotalLadymen = NumberLadies + NumberMen

'Copy Masters to Team columns
Columns("A:A").Copy Destination:=Columns("E:E")

'Add Lady and men to array
ArrayCount = 0
For i = 1 To NumberLadies
LadyMen(i - 1, PersonName) = Cells(i, "B")
Next i
For i = 1 To NumberMen
LadyMen(NumberLadies + i - 1, PersonName) = Cells(i, "C")
Next i

'give two chances for women to match up with Master
For i = 1 To 2
For j = 0 To (NumberLadies - 1)
'check if lady is already paired with master
PairedwithMaster = False
If i = 2 Then
'Random number starts at 0
If LadyMen(j, RanNumber) <= NumberMasters Then
'Lady is already paired with master
PairedwithMaster = True
End If
End If
'get unique number not already drawn
If PairedwithMaster = False Then
LadyMen(j, RanNumber) = 0
Do
Found = False
NewNumber = Int(TotalLadymen * Rnd()) + 1
For k = 0 To (NumberLadies - 1)
If NewNumber = LadyMen(k, RanNumber) Then
Found = True
Exit For
End If
Next k
Loop While (Found = True)
LadyMen(j, RanNumber) = NewNumber
End If
Next j
Next i

'assign random number to men
For j = NumberLadies To (TotalLadymen - 1)
'get unique number not already drawn
Do
Found = False
NewNumber = Int(TotalLadymen * Rnd()) + 1
For k = 0 To (TotalLadymen - 1)
If NewNumber = LadyMen(k, RanNumber) Then
Found = True
Exit For
End If
Next k
Loop While (Found = True)
LadyMen(j, RanNumber) = NewNumber
Next j
'sort ladies then men
For i = 0 To (NumberLadies - 2)
For j = i To (NumberLadies - 1)
If LadyMen(i, RanNumber) LadyMen(j, RanNumber) Then
temp = LadyMen(i, RanNumber)
LadyMen(i, RanNumber) = LadyMen(j, RanNumber)
LadyMen(j, RanNumber) = temp

temp = LadyMen(i, PersonName)
LadyMen(i, PersonName) = LadyMen(j, PersonName)
LadyMen(j, PersonName) = temp
End If
Next j
Next i
For i = NumberLadies To (TotalLadymen - 2)
For j = i To (TotalLadymen - 1)
If LadyMen(i, RanNumber) LadyMen(j, RanNumber) Then
temp = LadyMen(i, RanNumber)
LadyMen(i, RanNumber) = LadyMen(j, RanNumber)
LadyMen(j, RanNumber) = temp

temp = LadyMen(i, PersonName)
LadyMen(i, PersonName) = LadyMen(j, PersonName)
LadyMen(j, PersonName) = temp
End If
Next j
Next i

'Place Names in Teams columns
'first ladies
RowCount = NumberMasters + 1
For i = 0 To (NumberLadies - 1)
If LadyMen(i, RanNumber) <= NumberMasters Then
Cells(LadyMen(i, RanNumber), "F") = LadyMen(i, PersonName)
Else
Cells(RowCount, "F") = LadyMen(i, PersonName)
RowCount = RowCount + 1
End If
Next i
'now men
RowCount = NumberMasters + 1
For i = NumberLadies To (TotalLadymen - 1)
If LadyMen(i, RanNumber) <= NumberMasters Then
Cells(LadyMen(i, RanNumber), "G") = LadyMen(i, PersonName)
Else
Cells(RowCount, "G") = LadyMen(i, PersonName)
RowCount = RowCount + 1
End If
Next i

'Place
End Sub
Sub simulate()

NumberMasters = Cells(Rows.Count, "A").End(xlUp).Row
Ladywithmaster = 0
Menwithmaster = 0

For i = 1 To 1000
Call make_Teams
Ladywithmaster = WorksheetFunction. _
CountA(Range("F1:F" & NumberMasters)) + Ladywithmaster
Menwithmaster = WorksheetFunction. _
CountA(Range("G1:G" & NumberMasters)) + Menwithmaster
Next i
percentlady = 100 * (Ladywithmaster / 2000#)
percentmen = 100 * (Menwithmaster / 2000#)
MsgBox ("Percent Ladies paired with Masters = " & percentlady & _
Chr(13) & "Percent Men Paired with Masters = " & percentmen)
End Sub


"Joel" wrote:

I did the paring up a little different than described, but the result is the
the same probability.

'enter Names stating in Row 1
'enter Masters in Column A
'enter Ladies in Column B
'enter Men in Column C
'Teams will be in Column E, F, G

I always list masters in the order given.
Unique Random Numbers from the same list are given to men and woman starting
1 and going to the total number of combined men and woman. The lowest
numbers are assigned a master.

If you have 4 men and 4 women and 2 masters. I have each woman pick a
unique random number from 1 to 8 (total men and woman). If they chose a
number already picked the choose again until a unique number is given to each
woman. The woman who aren't assigned a master get to pick a second time.
They throw in there old number before picking a new number.

Next the men pick the ramaining numbers the woman haven't drawn. Then I
sort the woman by the random numbers they picked and I do the same thing for
the men.

If there arre two masters the person who go random number 1 is assigned to
master 1 and the person who got random number 2 is assined master 2. the
remaining men and woman are paired based on the random number chosen. The
lowest number man is paired with the lowest number woman. The next highest
man is paired with the next highest woman.

Sub make_Teams()
'Constants used to reference Array
Const PersonName = 0
Const RanNumber = 1
'enter Names stating in Row 1
'enter Masters in Column A
'enter Ladies in Column B
'enter Men in Column C
'Teams will be in Column E, F, G
Dim LadyMen(20, 2)

'clear old results
Range("E1:G20").ClearContents

NumberMasters = Cells(Rows.Count, "A").End(xlUp).Row
NumberLadies = Cells(Rows.Count, "B").End(xlUp).Row
NumberMen = Cells(Rows.Count, "C").End(xlUp).Row

TotalLadymen = NumberLadies + NumberMen

'Copy Masters to Team columns
Columns("A:A").Copy Destination:=Columns("E:E")

'Add Lady and men to array
ArrayCount = 0
For i = 1 To NumberLadies
LadyMen(i - 1, PersonName) = Cells(i, "B")
Next i
For i = 1 To NumberMen
LadyMen(NumberLadies + i - 1, PersonName) = Cells(i, "C")
Next i

'give two chances for women to match up with Master
For i = 1 To 2
For j = 0 To (NumberLadies - 1)
'check if lady is already paired with master
If i = 2 Then
'Random number starts at 0
If LadyMen(k, RanNumber) < NumberMasters Then
'Lady is already paired with master
PairedwithMaster = True
End If
Else
PairedwithMaster = False
End If
'get unique number not already drawn
If PairedwithMaster = False Then
LadyMen(k, RanNumber) = ""
Do
Found = False
NewNumber = Int(TotalLadymen * Rnd()) + 1
For k = 0 To (NumberLadies - 1)
If NewNumber = LadyMen(k, RanNumber) Then
Found = True
Exit For
End If
Next k
Loop While (Found = True)
LadyMen(j, RanNumber) = NewNumber
End If
Next j
Next i

'assign random number to men
For j = NumberLadies To (TotalLadymen - 1)
'get unique number not already drawn
Do
Found = False
NewNumber = Int(TotalLadymen * Rnd()) + 1
For k = 0 To (TotalLadymen - 1)
If NewNumber = LadyMen(k, RanNumber) Then
Found = True
Exit For
End If
Next k
Loop While (Found = True)
LadyMen(j, RanNumber) = NewNumber
Next j
'sort ladies then men
For i = 0 To (NumberLadies - 2)
For j = i To (NumberLadies - 1)
If LadyMen(i, RanNumber) LadyMen(j, RanNumber) Then
temp = LadyMen(i, RanNumber)
LadyMen(i, RanNumber) = LadyMen(j, RanNumber)
LadyMen(j, RanNumber) = temp

temp = LadyMen(i, PersonName)
LadyMen(i, PersonName) = LadyMen(j, PersonName)
LadyMen(j, PersonName) = temp
End If
Next j
Next i
For i = NumberLadies To (TotalLadymen - 2)
For j = i To (TotalLadymen - 1)
If LadyMen(i, RanNumber) LadyMen(j, RanNumber) Then
temp = LadyMen(i, RanNumber)
LadyMen(i, RanNumber) = LadyMen(j, RanNumber)
LadyMen(j, RanNumber) = temp

temp = LadyMen(i, PersonName)

Hello Sean,

My suggestion is:

Put your Master names into A1, A2, ...
Put your Ladies' names into C1, C2, ...
Put your Gents' names into E1, E2, ...

Copy the macro text of my UDF UniqRandInt from http://www.sulprobil.com/html/uniqrandint.html
into a new macro module:
1. Press ALT + F11
2. Insert a new module
3. Copy macro text into the module.
4. Go back to your worksheet

Now select B1 and B2 together and enter as array formula (enter with
CTRL + SHIFT + ENTER):
=UniqRandInt((COUNTA(A:A)+COUNTA(C:C)+COUNTA(E:E))/2)

Select D1:D4 and array-enter:
=UniqRandInt((COUNTA(A:A)+COUNTA(C:C)+COUNTA(E:E))/2)

Select F1:F4 and array-enter:
=INDEX(H:H,I1:I4)

Enter into G1:
=IF(COUNTIF(B:D,"="&INT((ROW()+1)/2))=2-MOD(ROW(),2),1E+300,INT((ROW()
+1)/2))
and copy down as far as necessary (to G10 in your example)

Enter into H1:
=SMALL(G:G,ROW())
and copy down to H4

Select I1:I4 and array-enter:
=UniqRandInt(COUNTA(E:E))

Now press F9 until you get a result which fits your needs :-)

If you do not wish to recalculate everything with new each new F9
comment out Application.Volatile in my UDF.

[Just a comment: This approach strictly follows your instruction -
IMHO it would not hurt if you just enter =ROW() into B1 and copy
down ... but delete B1:B4 first if you want to test this]

Regards,
Bernd