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)