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]