Trying to pair names randomly into teams??

P

poop91407

New Member
Joined
Jan 9, 2008
Messages
13
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!
 
Sort by date Sort by votes

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
Make sure that the player name starts from A1 (Hcap in B) with no headings
How about
Code: 
Sub test()
Dim a, i As Long, ii As Integer, Some_4 As Long, Some_3 As Long
Dim b(), teamNum As Long, n As Long
With Range("a1").CurrentRegion.Resize(,2)
    a = .Value
    ReDim Preserve a(1 To UBound(a,1), 1 To 3)
    Randomize
    For i = 1 To UBound(a,1)
        a(i,3) = Rnd
    Next
    VSortMA a, 1, UBound(a,1), 3
    Sum_3 = Choose((UBound(a,1) Mod 4) + 1, 0,3,2,1)
    Some_4 = Application.RoundUp(UBound(a,1) / 4, 0) - Some_3
    ReDim b(1 To Some_3 + Some_4, 1 To 9)
    For i = 1 To Some_4
        teamNum = teamNum + 1
        b(teamNum, 1) = teamNum
        For ii = 2 To 8 Step 2
            n = n + 1
            b(teamNum, ii) = a(n, 1)
            b(teamNum, ii + 1) = a(n, 2)
        Next
    Next
    If Some_3 > 0 Then
        For i = 1 To Some_3
            teamNum = teamNum + 1
            b(teamNum, 1) = teamNum
            For ii = 2 To 6 Step 2
                n = n + 1
                b(teamNum + 4Some, ii) = a(n, 1)
                b(teamNum + 4Some, ii + 1) = a(n, 2)
            Next
        Next
    End If
    With .Offset(,4).Resize(1,1)
        .CurrentRegion.Clear
        .Resize(,3).Value = [{"Team #","Player1","Hcap"}]
        With .Offset(,1).Resize(,2)
            .Autofill .Resize(,8)
        End With
        With .Offset(1).Resize(teamNum, 9)
            .Value = b
            .Borders.Weight = xlHairLine
            .BorderAround Weight:=xlThin
            .EntireColumn.AutoFit
        End With
    End With
End With
End Sub
 
Private Sub VSortMA(ary, LB, UB, ref) 
Dim M As Variant, i As Long, ii As Long, iii As Long
i = UB : ii = LB 
M = ary(Int((LB+UB)/2),ref) 
Do While ii <= i 
     Do While ary(ii,ref) < M 
          ii = ii + 1 
     Loop 
     Do While ary(i,ref) > M 
          i = i - 1 
     Loop 
     If ii <= i Then 
          For iii = LBound(ary,2) To UBound(ary,2) 
               temp = ary(ii,iii) : ary(ii,iii) = ary(i,iii)
               ary(i,iii) = temp 
          Next 
          ii = ii + 1 : i = i - 1 
     End If 
Loop 
If LB < i Then VSortMA ary, LB, i, ref 
If ii < UB Then VSortMA ary, ii, UB, ref 
End Sub
 
Upvote 0
Hi, Exchange my original code for the one below:-
This code does as before plus it separates By colour the number of players into groups of 4 and groups of 3.
Will colour groups of 4 and above
Code: 
Dim x As Range, RanRng As Range, z As Range, oRes, Ray
Dim i As Integer, j As Integer, real, oSt As Integer, cl As Range
Dim oCol As Integer, a As Integer, c As Integer, Y As Integer, Dex
Dim ans, div As Integer, ans2, Lg, Col As Integer, colx As Integer

Set RanRng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
    ReDim oRes(1 To RanRng.Rows.Count)
       RanRng.Offset(, 2).ClearContents
            RanRng.Offset(, 20).ClearContents

a = RanRng.Count

Columns("C").Interior.ColorIndex = xlNone
Columns("C").ClearContents

'If a >  Then
 For div = 1 To Int(a / 4)
   c = c + 1
     Y = a - (4 * c)
       If Y Mod 3 = 0 Then
          ans = c
        End If
ans2 = (a - (4 * ans)) / 3
Next div
'End If
 If ans = "" Then ans = 0
 If ans2 = "" Then ans2 = 0
'MsgBox ans * 4
'MsgBox ans2 * 3

colx = 35

Lg = ans * 4 + ans2 * 3
For Col = 1 To ans * 4
   Cells(Col, 3).Interior.ColorIndex = colx
     If colx = 34 And Col Mod 4 = 0 Then
         colx = 35
     ElseIf colx = 35 And Col Mod 4 = 0 Then
          colx = 34
        End If
Next Col

For Col = ans * 4 + 1 To Lg
    Cells(Col, 3).Interior.ColorIndex = colx
        Dex = Col - ans * 4
    If colx = 34 And Dex Mod 3 = 0 Then
            colx = 35
        ElseIf colx = 35 And Dex Mod 3 = 0 Then
                colx = 34
            End If
Next Col

For Each x In RanRng.Offset(, 20)
    j = Int(Rnd() * RanRng.Rows.Count) + 1
Set z = RanRng.Offset(, 20).Find(j, lookat:=xlWhole)
    While Not z Is Nothing
        j = Int(Rnd() * RanRng.Rows.Count) + 1
Set z = RanRng.Offset(, 20).Find(j, lookat:=xlWhole)
Wend
x = j
oRes(x.Row) = j
Next x
ReDim real(1 To RanRng.Rows.Count)

For oSt = 1 To UBound(oRes)
    real(oSt) = Cells(oRes(oSt), 1)
Next oSt
Range("C1").Resize(RanRng.Count).Value = Application.Transpose(real)
Regards Mick
 
Upvote 0
Awesome.... :)





MickG said:
Hi, Exchange my original code for the one below:-
This code does as before plus it separates By colour the number of players into groups of 4 and groups of 3.
Will colour groups of 4 and above
Code: 
Dim x As Range, RanRng As Range, z As Range, oRes, Ray
Dim i As Integer, j As Integer, real, oSt As Integer, cl As Range
Dim oCol As Integer, a As Integer, c As Integer, Y As Integer, Dex
Dim ans, div As Integer, ans2, Lg, Col As Integer, colx As Integer

Set RanRng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
    ReDim oRes(1 To RanRng.Rows.Count)
       RanRng.Offset(, 2).ClearContents
            RanRng.Offset(, 20).ClearContents

a = RanRng.Count

Columns("C").Interior.ColorIndex = xlNone
Columns("C").ClearContents

'If a >  Then
 For div = 1 To Int(a / 4)
   c = c + 1
     Y = a - (4 * c)
       If Y Mod 3 = 0 Then
          ans = c
        End If
ans2 = (a - (4 * ans)) / 3
Next div
'End If
 If ans = "" Then ans = 0
 If ans2 = "" Then ans2 = 0
'MsgBox ans * 4
'MsgBox ans2 * 3

colx = 35

Lg = ans * 4 + ans2 * 3
For Col = 1 To ans * 4
   Cells(Col, 3).Interior.ColorIndex = colx
     If colx = 34 And Col Mod 4 = 0 Then
         colx = 35
     ElseIf colx = 35 And Col Mod 4 = 0 Then
          colx = 34
        End If
Next Col

For Col = ans * 4 + 1 To Lg
    Cells(Col, 3).Interior.ColorIndex = colx
        Dex = Col - ans * 4
    If colx = 34 And Dex Mod 3 = 0 Then
            colx = 35
        ElseIf colx = 35 And Dex Mod 3 = 0 Then
                colx = 34
            End If
Next Col

For Each x In RanRng.Offset(, 20)
    j = Int(Rnd() * RanRng.Rows.Count) + 1
Set z = RanRng.Offset(, 20).Find(j, lookat:=xlWhole)
    While Not z Is Nothing
        j = Int(Rnd() * RanRng.Rows.Count) + 1
Set z = RanRng.Offset(, 20).Find(j, lookat:=xlWhole)
Wend
x = j
oRes(x.Row) = j
Next x
ReDim real(1 To RanRng.Rows.Count)

For oSt = 1 To UBound(oRes)
    real(oSt) = Cells(oRes(oSt), 1)
Next oSt
Range("C1").Resize(RanRng.Count).Value = Application.Transpose(real)
Regards Mick
Click to expand...
 
Upvote 0
Still get a compile error?

b(teamNum + 4Some, ii) = a(n, 1).... was highlighted?

Thanks.

jindon said:
Make sure that the player name starts from A1 (Hcap in B) with no headings
How about
Code: 
Sub test()
Dim a, i As Long, ii As Integer, Some_4 As Long, Some_3 As Long
Dim b(), teamNum As Long, n As Long
With Range("a1").CurrentRegion.Resize(,2)
    a = .Value
    ReDim Preserve a(1 To UBound(a,1), 1 To 3)
    Randomize
    For i = 1 To UBound(a,1)
        a(i,3) = Rnd
    Next
    VSortMA a, 1, UBound(a,1), 3
    Sum_3 = Choose((UBound(a,1) Mod 4) + 1, 0,3,2,1)
    Some_4 = Application.RoundUp(UBound(a,1) / 4, 0) - Some_3
    ReDim b(1 To Some_3 + Some_4, 1 To 9)
    For i = 1 To Some_4
        teamNum = teamNum + 1
        b(teamNum, 1) = teamNum
        For ii = 2 To 8 Step 2
            n = n + 1
            b(teamNum, ii) = a(n, 1)
            b(teamNum, ii + 1) = a(n, 2)
        Next
    Next
    If Some_3 > 0 Then
        For i = 1 To Some_3
            teamNum = teamNum + 1
            b(teamNum, 1) = teamNum
            For ii = 2 To 6 Step 2
                n = n + 1
                b(teamNum + 4Some, ii) = a(n, 1)
                b(teamNum + 4Some, ii + 1) = a(n, 2)
            Next
        Next
    End If
    With .Offset(,4).Resize(1,1)
        .CurrentRegion.Clear
        .Resize(,3).Value = [{"Team #","Player1","Hcap"}]
        With .Offset(,1).Resize(,2)
            .Autofill .Resize(,8)
        End With
        With .Offset(1).Resize(teamNum, 9)
            .Value = b
            .Borders.Weight = xlHairLine
            .BorderAround Weight:=xlThin
            .EntireColumn.AutoFit
        End With
    End With
End With
End Sub
 
Private Sub VSortMA(ary, LB, UB, ref) 
Dim M As Variant, i As Long, ii As Long, iii As Long
i = UB : ii = LB 
M = ary(Int((LB+UB)/2),ref) 
Do While ii <= i 
     Do While ary(ii,ref) < M 
          ii = ii + 1 
     Loop 
     Do While ary(i,ref) > M 
          i = i - 1 
     Loop 
     If ii <= i Then 
          For iii = LBound(ary,2) To UBound(ary,2) 
               temp = ary(ii,iii) : ary(ii,iii) = ary(i,iii)
               ary(i,iii) = temp 
          Next 
          ii = ii + 1 : i = i - 1 
     End If 
Loop 
If LB < i Then VSortMA ary, LB, i, ref 
If ii < UB Then VSortMA ary, ii, UB, ref 
End Sub
Click to expand...
 
Upvote 0
Hi, Paste this into another Command Bar on another sheet.
It will list all the colour Numbers.
Look down your Pairing code as far as "Next col"
Change all the Numbers Shown as "34" to another colour number of your choice and then change all the Numbers Shown as "35" to aother colour number of you choice.
Make sure you get them all. else you might get funny results
Code: 
Dim ac As Integer, Dn As Integer, c As Integer
Range("a1").Value = "Visual Basic Colours and Index Numbers"
Range("a1").Font.Size = 14
For ac = 1 To 8 Step 2
For Dn = 2 To 15
On Error Resume Next
c = c + 1
Cells(Dn, ac) = c
Cells(Dn, ac).Offset(, 1).Interior.ColorIndex = c
Next Dn
Next ac

Regards Mick
 
Upvote 0
Rich (BB code): 
                b(teamNum + 4Some, ii) = a(n, 1)
                b(teamNum + 4Some, ii + 1) = a(n, 2)
should be
Rich (BB code): 
                b(teamNum + Some_4, ii) = a(n, 1)
                b(teamNum + Some_4, ii + 1) = a(n, 2)
 
Upvote 0
When I replace...

I get a "subscript out of range" error?

Thanks.


jindon said:
Rich (BB code): 
                b(teamNum + 4Some, ii) = a(n, 1)
                b(teamNum + 4Some, ii + 1) = a(n, 2)
should be
Rich (BB code): 
                b(teamNum + Some_4, ii) = a(n, 1)
                b(teamNum + Some_4, ii + 1) = a(n, 2)
Click to expand...
 
Upvote 0
You da man!!! :)

MickG said:
Hi, Paste this into another Command Bar on another sheet.
It will list all the colour Numbers.
Look down your Pairing code as far as "Next col"
Change all the Numbers Shown as "34" to another colour number of your choice and then change all the Numbers Shown as "35" to aother colour number of you choice.
Make sure you get them all. else you might get funny results
Code: 
Dim ac As Integer, Dn As Integer, c As Integer
Range("a1").Value = "Visual Basic Colours and Index Numbers"
Range("a1").Font.Size = 14
For ac = 1 To 8 Step 2
For Dn = 2 To 15
On Error Resume Next
c = c + 1
Cells(Dn, ac) = c
Cells(Dn, ac).Offset(, 1).Interior.ColorIndex = c
Next Dn
Next ac

Regards Mick
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

JenniferMurphy
  • Question
How to tally tennis court pairings?
Replies
9
Views
320
JenniferMurphy
JenniferMurphy
B
  • Question
Need help for my Disc Golf League
Replies
1
Views
347
AhoyNC
A
W
  • Question
Golf Trip Pairings with minimal repeats
Replies
6
Views
6K
Graymalkin
G
A
  • Question
Print a range on labels from Excel
Replies
2
Views
1K
adambc
A
S
  • Question
Golf league schedule help
Replies
3
Views
3K
Logit
Logit

Forum statistics

Threads
1,214,927
Messages
6,122,309
Members
449,080
Latest member
jmsotelo

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top