Making Golf Teams - Snake Order

jlhoover3

Board Regular
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!

VBA Code:
``````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``````

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!

Eric W

MrExcel MVP
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:

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
ABCDEF
1PlayerRating# of teamsMax Rating Difference
2Player 113.520.4
3Player 212.5
4Player 311
5Player 410.5
6Player 58
7Player 67
8Player 76
Sheet6

You can run this code:

VBA 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
ABCDEFGHIJKLM
1PlayerRating# of teamsMax Rating DifferenceTeam ATeam B
2Player 113.520.4Player 212.5Player 311
3Player 212.5Player 113.5Player 58
4Player 311Player 76Player 410.5
5Player 410.5Player 67
6Player 58
7Player 679.759.833333
8Player 76
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
IJKLM
1Team ATeam B
2Player 58Player 67
3Player 311Player 212.5
4Player 76Player 410.5
5Player 113.5
6
79.62510
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

Board Regular
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

Board Regular
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

Board Regular

And yet another approach:

VBA Code:
``````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

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

Eric W

MrExcel MVP
Starting with:

Book1
ABCD
1PlayerPoints# of groups
2113.53
3212.5
4311
5410.5
658
767
876
985
1094
11103
12112
Sheet8

Try this macro:

VBA Code:
``````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

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

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

Board Regular
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!

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

1,164,095
Messages
5,835,363
Members
430,352
Latest member
xvidzoro

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.

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

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