Making Golf Teams - Snake Order

[jlhoover3]

Good Morning! I'm trying to build a golf pairing list for our Men's Group Association, but the code is really kicking my butt. Long story short, I'm trying to build an excel sheet to create my pairings and groups based on a range of cells. I want the pairings to go in snake order based on their value of points. This also has to be based on what their input is on how many teams their should be.

A	B	C	D	E	F	G	H	I
Player	Points			Player A	Player B	Player C	Player D	Player E
Player 1	13.5		Group #1	Player 1	Player 4	Player 5
Player 2	12.5		Group #2	Player 2	Player 3	Player 6	Player 7
Player 3	11
Player 4	10.5
Player 5	8
Player 6	7
Player 7	6

For example above, Players are in order based on points, and now I want vba to get me the result in Range(E2:I3). I want the mod = 1 to go to the last group. Hope this makes sense. The players list can range anywhere from 4 to unlimited, as well as Groups. The player list will be calculated based on whomever has checked in. The VBA will ask the question on how many groups you are wanting. I found the code below, but it's not exactly what I'm looking for. Very close! I'm trying to play around with it to get what I need. Thanks again!

Sub MyMacro()

    Dim teams As Long
    Dim rounds As Long
    Dim c As Long
    Dim r As Long
    Dim i As Long
    Dim hr As Long
    Dim hc As Long
    
    Application.ScreenUpdating = False
    
'   Indicate number of header rows and columns
    hr = 5
    hc = 1
    
'   Prompt for number of teams
    teams = InputBox("How many teams are there?")
    
'   Prompt for number of rounds
    rounds = InputBox("How many rounds are there?")
   
'   Populate data, starting in row 2
    For r = 1 To rounds
'       Populate columns, starting in column A
        If (r Mod 2) = 1 Then
'           Go forward
            For c = 1 To teams
                i = i + 1
                Cells(r + hr, c + hc) = i
            Next c
        Else
'           Go backward
            For c = teams To 1 Step -1
                 i = i + 1
                Cells(r + hr, c + hc) = i
            Next c
        End If
    Next r
    
    Application.ScreenUpdating = True
    
End Sub

 

[Eric W]

I don't have time right now to try to figure out your code, but this did remind me of a macro I wrote a while back that does a very similar task. The original thread is here:

VBA to randomly select teams from list of players

Excel 2013, Win 7 Pro Starting with column A (Player Names) and column B (Player rating - value between 0-10), I need a macro to divide the players into either 2, 4 or 6 teams randomly. Column A would have less than 100 names. Teams are named TeamA, TeamB...TeamF. TeamA competes against...

www.mrexcel.com

That thread goes on for several pages with several variations. It also has some old style HTML that hasn't been cleaned up yet. But here's the gist: Starting with a sheet like this:

Book1
	A	B	C	D	E	F
1	Player	Rating		# of teams		Max Rating Difference
2	Player 1	13.5		2		0.4
3	Player 2	12.5
4	Player 3	11
5	Player 4	10.5
6	Player 5	8
7	Player 6	7
8	Player 7	6
Sheet6

You can run this code:

Sub MakeTeams()
Dim Players(200, 3), TeamSize(10) As Integer, TeamRating(10) As Double
Dim i As Integer, r As Integer, j As Integer, c As Integer, ctr As Integer
Dim Numplayers As Integer, NumTeams As Integer, trials As Integer
Dim t As Integer, tc As Integer, MaxRating As Double, MinRating As Double
' Written by Eric W.  1/9/2016

' How many teams?
    NumTeams = Range("D2").Value
    If NumTeams > 10 Or NumTeams < 2 Or Int(NumTeams) <> NumTeams Then
        MsgBox "The number of teams must be an integer from 2-10."
        Exit Sub
    End If
    
' Read all the players and ratings
    r = 2
    Erase Players, TeamSize, TeamRating
    
    While Cells(r, "A") <> ""
        If r > 201 Then
            MsgBox "The number of players must be under 200."
            Exit Sub
        End If
        Players(r - 1, 1) = Cells(r, "A")
        Players(r - 1, 2) = Cells(r, "B")
        r = r + 1
    Wend
    Numplayers = r - 2
    
' Figure out the team sizes
    For r = 1 To NumTeams
        TeamSize(r) = Int(Numplayers / NumTeams) + IIf(r <= (Numplayers Mod NumTeams), 1, 0)
    Next r
    
' Make random teams
    trials = 0
    While trials < 100
        Call Shuffle(Players, Numplayers)
        
' Figure out the team ratings
        t = 1
        tc = 1
        Erase TeamRating
        MaxRating = -1
        MinRating = 1000
        For i = 1 To Numplayers
            TeamRating(t) = TeamRating(t) + Players(i, 2)
            tc = tc + 1
            If tc > TeamSize(t) Then
                TeamRating(t) = TeamRating(t) / TeamSize(t)
                If TeamRating(t) > MaxRating Then MaxRating = TeamRating(t)
                If TeamRating(t) < MinRating Then MinRating = TeamRating(t)
                t = t + 1
                tc = 1
            End If
        Next i

' Max team rating - min team rating within the limit?
        If MaxRating - MinRating <= Cells(2, "F") Then GoTo PrintTeams
        
' Nope, try again
        trials = trials + 1
    Wend
    
    MyText = "Unable to find a valid set of teams in 100 tries." & Chr(10) & Chr(10)
    MyText = MyText & "You may try again, or try again with a higher MaxRatingDiff."
    MsgBox MyText
    Exit Sub
    
' Print the teams
PrintTeams:
    Range("J1:AP100").ClearContents
    ctr = 1
    For i = 1 To NumTeams
        c = i * 3 + 6
        Cells(1, c) = "Team " & Chr(64 + i)
        For j = 1 To TeamSize(i)
            Cells(j + 1, c) = Players(ctr, 1)
            Cells(j + 1, c + 1) = Players(ctr, 2)
            ctr = ctr + 1
        Next j
        Cells(TeamSize(1) + 3, c + 1) = TeamRating(i)
    Next i
    
End Sub
' This team will randomly shuffle the players
' (It's really a bad sort, but with under 100 players, it should be good enough.)
Sub Shuffle(ByRef Players, ByVal Numplayers)

' Assign a random number to each player
    For i = 1 To Numplayers
        Players(i, 3) = Rnd()
    Next i
    
' Now sort by the random numbers
    For i = 1 To Numplayers
        For j = 1 To Numplayers
            If Players(i, 3) > Players(j, 3) Then
                a = Players(i, 1)
                b = Players(i, 2)
                c = Players(i, 3)
                Players(i, 1) = Players(j, 1)
                Players(i, 2) = Players(j, 2)
                Players(i, 3) = Players(j, 3)
                Players(j, 1) = a
                Players(j, 2) = b
                Players(j, 3) = c
            End If
        Next j
    Next i
    
End Sub

and it will come up with a set of teams with an average rating as close as possible. In this case it came up with:

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Player	Rating		# of teams		Max Rating Difference			Team A			Team B
2	Player 1	13.5		2		0.4			Player 2	12.5		Player 3	11
3	Player 2	12.5							Player 1	13.5		Player 5	8
4	Player 3	11							Player 7	6		Player 4	10.5
5	Player 4	10.5							Player 6	7
6	Player 5	8
7	Player 6	7								9.75			9.833333
8	Player 7	6
9
Sheet6

The team sizes will always be +/- 1 from each other. I realize that this doesn't follow the snake order you wanted, in fact in this case the top 2 players are on the same team. But you can rerun the macro and get something else. I got this the next time I ran it:

Book1
	I	J	K	L	M
1	Team A			Team B
2	Player 5	8		Player 6	7
3	Player 3	11		Player 2	12.5
4	Player 7	6		Player 4	10.5
5	Player 1	13.5
6
7		9.625			10
Sheet6

So try it out for now and see if it works for you. If not, I'll take a look at your original code when I have some time.

 

[jlhoover3]

Thanks Eric! I appreciate your time giving me your macro! I will utilize this as option as well and see if I can work off this. I'll let you know how it works out!

 

[jlhoover3]

I have that working for random order, which is great! Thank you so much for the code. However, our game involves low score on each hole, and so I need to be able to do a snake draft as well just so teams are broken down evenly by an A, B, C, and possible D, E groups. I'll continue to try and find a solution, but any help would be fantastic! Thanks again!

 

[Sulprobil]

And yet another approach:

Option Explicit

Enum col_worksheet
    col_LBound = 0 'To be able to iterate from here + 1
    col_in_player_no
    col_in_player_name
    col_in_player_handicap
    col_blank_1
    col_in_team_stats
    col_blank_2
    col_in_sim_stats
    col_blank_3
    col_out_team_no
    col_out_player_name
    col_out_player_handicap
    col_blank_4
    col_stat_team_no
    col_stat_sum_handicap
    col_Ubound 'To be able iterate until here - 1
End Enum 'col_worksheet

Sub sbTeamGolf()
'Implements a simple Monte Carlo simulation to randomly generate teams,
'keeping track of the teams with the lowest standard deviation of
'handicap sums.
'This sub needs VBAUniqRandInt - google for sulprobil and uniqrandint.
'and the SystemState class - google for sulprobil and systemstate.
'Reverse("moc.LiborPlus.www") PB 01-May-2015 V0.2

Dim i As Long, j As Long, k As Long, n As Long
Dim teamcount As Long
Dim playersperteam As Long
Dim stdev_hc_sum As Double, min_stdev As Double
Dim s As Double
Dim v As Variant
Dim wsI As Worksheet
Dim state As SystemState

'Initialize
Set state = New SystemState
Set wsI = Sheets("Input")
teamcount = wsI.Range("TeamCount")
wsI.Range("PlayersPerTeam").Calculate
playersperteam = wsI.Range("PlayersPerTeam")
n = teamcount * playersperteam
ReDim hc(1 To n) As Double
ReDim mina(1 To n) As Double
ReDim hc_sum(1 To teamcount) As Double
For j = 1 To n
    hc(j) = wsI.Cells(j + 1, col_in_player_handicap)
Next j
min_stdev = 1E+300

k = 1
Do
    v = VBUniqRandInt(n, n)
    For i = 1 To teamcount
        hc_sum(i) = 0
        For j = 1 To playersperteam
            hc_sum(i) = hc_sum(i) + hc(v((i - 1) * playersperteam + j))
        Next j
    Next i
    stdev_hc_sum = WorksheetFunction.StDev(hc_sum)
    If stdev_hc_sum < min_stdev Then
        For i = 1 To n
            mina(i) = v(i)
        Next i
        min_stdev = stdev_hc_sum
        Application.StatusBar = "Iteration " & k & ", new min stdev = " & min_stdev
    End If
    k = k + 1
Loop Until k > wsI.Range("SimCount")

wsI.Range(wsI.Cells(2, col_out_team_no), _
    wsI.Cells(1000, col_stat_sum_handicap)).ClearContents
      
For i = 1 To teamcount
    s = 0#
    For j = 1 To playersperteam
        wsI.Cells(1 + (i - 1) * playersperteam + j, col_out_team_no) = i
        wsI.Cells(1 + (i - 1) * playersperteam + j, col_out_player_name) = _
            wsI.Cells(1 + mina((i - 1) * playersperteam + j), col_in_player_name)
        wsI.Cells(1 + (i - 1) * playersperteam + j, col_out_player_handicap) = _
            wsI.Cells(1 + mina((i - 1) * playersperteam + j), col_in_player_handicap)
        s = s + wsI.Cells(1 + mina((i - 1) * playersperteam + j), col_in_player_handicap)
    Next j
    wsI.Cells(1 + i, col_stat_team_no) = i
    wsI.Cells(1 + i, col_stat_sum_handicap) = s
Next i
wsI.Cells(2 + teamcount, col_stat_team_no) = "StDev"
wsI.Cells(2 + teamcount, col_stat_sum_handicap) = min_stdev
End Sub

 

[jlhoover3]

Thank you Sulprobil. This is working nicely! Yet, another option I can add to this program. Greatly appreciated!

 

[Eric W]

Starting with:

Book1
	A	B	C	D
1	Player	Points		# of groups
2	1	13.5		3
3	2	12.5
4	3	11
5	4	10.5
6	5	8
7	6	7
8	7	6
9	8	5
10	9	4
11	10	3
12	11	2
Sheet8

Try this macro:

Sub SnakeOrder()
Dim MyDat As Variant, ng As Long, np As Long, r As Long, c As Long, ud As Long, i As Long
Dim op() As Variant

' Read the names
    MyDat = Range("A2:B" & Cells(Rows.Count, "A").End(xlUp).Row).Value
    ng = Range("D2").Value
    
' Figure out how many players per group
    np = (UBound(MyDat) \ ng) + IIf(UBound(MyDat) Mod ng > 0, 1, 0)
    ReDim op(0 To ng, 0 To np)
    
' r = row, c = column, ud = up/down
    r = 1
    c = 1
    ud = 1
' do every name
    For i = 1 To UBound(MyDat)
        op(r, c) = MyDat(i, 1)
' have we hit the top or bottom of a column?
        If (ud = 1 And r = ng) Or (ud = -1 And r = 1) Then
            ud = ud * -1        ' if so, change direction
            c = c + 1           ' and go to the next column
        Else
            r = r + ud          ' if not, just go to the next line
        End If
    Next i
    
' add the headings
    For i = 1 To ng
        op(i, 0) = "Group #" & i
    Next i
    For i = 1 To np
        op(0, i) = "Player " & Chr(64 + i)
    Next i
    
' print it out
    Range("F1").Resize(ng + 1, np + 1) = op
    
End Sub

It'll put the results in F1, down and over as needed. As you can see, I started from scratch. I think you'll likely want some tweaks, but see how it works.

 

[jlhoover3]

Eric, that is exactly what I was looking for! I appreciate you taking the time in helping me. Once I finish my program, I'll give you a preview of what is being built! Again, thank you, and everyone else!