Sulprobil
Search…
sbTeamGolf
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:
1. The class SystemState helps to reduce runtime. 2. 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. 3. Reshuffle a set of elements with UniqRandInt. 4. Sample data I generated with sbGenerateTestData.
Please read my Disclaimer.
1
Option Explicit
2
3
Enum col_worksheet
4
col_LBound = 0 'To be able to iterate from here + 1
5
col_in_player_no
6
col_in_player_name
7
col_in_player_handicap
8
col_blank_1
9
col_in_team_stats
10
col_blank_2
11
col_in_sim_stats
12
col_blank_3
13
col_out_team_no
14
col_out_player_name
15
col_out_player_handicap
16
col_blank_4
17
col_stat_team_no
18
col_stat_sum_handicap
19
col_Ubound 'To be able iterate until here - 1
20
End Enum 'col_worksheet
21
22
Sub sbTeamGolf()
23
'Implements a simple Monte Carlo simulation to randomly generate teams,
24
'keeping track of the teams with the lowest standard deviation of
25
'handicap sums.
26
'This sub needs VBAUniqRandInt - google for sulprobil and uniqrandint.
27
'and the SystemState class - google for sulprobil and systemstate.
28
'Reverse("moc.LiborPlus.www") PB 01-May-2015 V0.2
29
30
Dim i As Long, j As Long, k As Long, n As Long
31
Dim teamcount As Long
32
Dim playersperteam As Long
33
Dim stdev_hc_sum As Double, min_stdev As Double
34
Dim s As Double
35
Dim v As Variant
36
Dim wsI As Worksheet
37
Dim state As SystemState
38
39
'Initialize
40
Set state = New SystemState
41
Set wsI = Sheets("Input")
42
teamcount = wsI.Range("TeamCount")
43
wsI.Range("PlayersPerTeam").Calculate
44
playersperteam = wsI.Range("PlayersPerTeam")
45
n = teamcount * playersperteam
46
ReDim hc(1 To n) As Double
47
ReDim mina(1 To n) As Double
48
ReDim hc_sum(1 To teamcount) As Double
49
For j = 1 To n
50
hc(j) = wsI.Cells(j + 1, col_in_player_handicap)
51
Next j
52
min_stdev = 1E+300
53
54
k = 1
55
Do
56
v = VBUniqRandInt(n, n)
57
For i = 1 To teamcount
58
hc_sum(i) = 0
59
For j = 1 To playersperteam
60
hc_sum(i) = hc_sum(i) + hc(v((i - 1) * playersperteam + j))
61
Next j
62
Next i
63
stdev_hc_sum = WorksheetFunction.StDev(hc_sum)
64
If stdev_hc_sum < min_stdev Then
65
For i = 1 To n
66
mina(i) = v(i)
67
Next i
68
min_stdev = stdev_hc_sum
69
Application.StatusBar = "Iteration " & k & ", new min stdev = " & min_stdev
70
End If
71
k = k + 1
72
Loop Until k > wsI.Range("SimCount")
73
74
wsI.Range(wsI.Cells(2, col_out_team_no), _
75
wsI.Cells(1000, col_stat_sum_handicap)).ClearContents
76
77
For i = 1 To teamcount
78
s = 0#
79
For j = 1 To playersperteam
80
wsI.Cells(1 + (i - 1) * playersperteam + j, col_out_team_no) = i
81
wsI.Cells(1 + (i - 1) * playersperteam + j, col_out_player_name) = _
82
wsI.Cells(1 + mina((i - 1) * playersperteam + j), col_in_player_name)
83
wsI.Cells(1 + (i - 1) * playersperteam + j, col_out_player_handicap) = _
84
wsI.Cells(1 + mina((i - 1) * playersperteam + j), col_in_player_handicap)
85
s = s + wsI.Cells(1 + mina((i - 1) * playersperteam + j), col_in_player_handicap)
86
Next j
87
wsI.Cells(1 + i, col_stat_team_no) = i
88
wsI.Cells(1 + i, col_stat_sum_handicap) = s
89
Next i
90
wsI.Cells(2 + teamcount, col_stat_team_no) = "StDev"
91
wsI.Cells(2 + teamcount, col_stat_sum_handicap) = min_stdev
92
End Sub
Copied!
sbTeamGolf.xlsm
34KB
Binary
sbTeamGolf.xlsm (Excel 2016 tested)
Last modified 1yr ago
Copy link