Abstract
You and your 15 friends want to play golf in teams of 4 and you wonder how to come up with a fair distribution of teams?
Here you go:
This program combines several features which I like to use:
-
The class SystemState helps to reduce runtime.
-
With enumerations I organize access to worksheet columns flexibly - for additional columns or deleted columns you just amend the enumeration, and the program will re-adjust automatically.
-
Reshuffle a set of elements with UniqRandInt.
-
Sample data I generated with sbGenerateTestData.
Appendix – sbTeamGolf Code
Please read my Disclaimer.
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 VBUniqRandInt - google for sulprobil and uniqrandint.
'and the SystemState class - google for sulprobil and systemstate.
'Source (EN): http://www.sulprobil.com/sbteamgolf_en/
'Source (DE): http://www.bplumhoff.de/sbteamgolf_de/
'(C) (P) by Bernd Plumhoff 01-May-2015 PB 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
Please read my Disclaimer.
sbTeamGolf.xlsm [36 KB Excel file, open and use at your own risk]