Abstract
Sie und Ihre 15 Freunde wollen in 4 Teams spielen mit je 4 Spielern und Sie fragen sich, wie Sie die Teams zufällig aber fair aufstellen können?
So kann man dies erreichen:
Dieses Programm vereint mehrere Funktionalitäten, die ich gern nutze:
-
Die Klasse SystemState reduziert die Laufzeit.
-
Mit Enumerierungen organisiere ich den Zugriff auf Spalten flexibel - für zusätzliche oder entfallende Spalten ändere ich lediglich die Enumerierung, und das Programm passt die Spaltennummern automatisch an.
-
Neues Mischen einer Menge von Elementen mit UniqRandInt.
-
Testdaten (Namen) erzeugte ich mit sbGenerateTestData.
Appendix – Programmcode sbGenerateTeams
Bitte beachten: Dieses Programm benötigt (verwendet) die Klasse SystemState und die benutzerdefinierte Funktion VBUniqRandInt.
Bitte den Haftungsausschluss im Impressum beachten.
Option Explicit
#Const I_Want_Colors = True
#If I_Want_Colors Then
Private Enum xlCI 'Excel Color Index
: xlCIBlack = 1: xlCIWhite: xlCIRed: xlCIBrightGreen: xlCIBlue '1 - 5
: xlCIYellow: xlCIPink: xlCITurquoise: xlCIDarkRed: xlCIGreen '6 - 10
: xlCIDarkBlue: xlCIDarkYellow: xlCIViolet: xlCITeal: xlCIGray25 '11 - 15
: xlCIGray50: xlCIPeriwinkle: xlCIPlum: xlCIIvory: xlCILightTurquoise '16 - 20
: xlCIDarkPurple: xlCICoral: xlCIOceanBlue: xlCIIceBlue: xlCILightBrown '21 - 25
: xlCIMagenta2: xlCIYellow2: xlCICyan2: xlCIDarkPink: xlCIDarkBrown '26 - 30
: xlCIDarkTurquoise: xlCISeaBlue: xlCISkyBlue: xlCILightTurquoise2: xlCILightGreen '31 - 35
: xlCILightYellow: xlCIPaleBlue: xlCIRose: xlCILavender: xlCITan '36 - 40
: xlCILightBlue: xlCIAqua: xlCILime: xlCIGold: xlCILightOrange '41 - 45
: xlCIOrange: xlCIBlueGray: xlCIGray40: xlCIDarkTeal: xlCISeaGreen '46 - 50
: xlCIDarkGreen: xlCIGreenBrown: xlCIBrown: xlCIDarkPink2: xlCIIndigo '51 - 55
: xlCIGray80 '56
End Enum
#End If
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_skill
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_skill
col_blank_4
col_stat_team_no
col_stat_sum_skills
col_Ubound 'To be able iterate until here - 1
End Enum 'col_worksheet
Sub sbGenerateTeams()
'Implements a simple Monte Carlo simulation to randomly generate
'teams fairly, keeping track of the teams with the lowest standard
'deviation of skill 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/sbgenerateteams_en/
'Source (DE): http://www.bplumhoff.de/sbgenerateteams_de/
'(C) (P) by Bernd Plumhoff 30-Jul-2022 PB V0.3
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 state As SystemState
'Initialize
Set state = New SystemState
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
wsI.Cells.Interior.ColorIndex = False
#If I_Want_Colors Then
wsI.Range("A1:C1").Interior.ColorIndex = xlCIYellow
wsI.Range("E1").Interior.ColorIndex = xlCIYellow
wsI.Range("G1").Interior.ColorIndex = xlCIYellow
wsI.Range("E4").Interior.ColorIndex = xlCIYellow
wsI.Range("E2").Interior.ColorIndex = xlCILightYellow
wsI.Range("G2").Interior.ColorIndex = xlCILightYellow
wsI.Range("E5").Interior.ColorIndex = xlCILightYellow
wsI.Range("I1:K1").Interior.ColorIndex = xlCIBrightGreen
wsI.Range("M1:N1").Interior.ColorIndex = xlCIBrightGreen
wsI.Range("M" & teamcount + 2 & ":N" & teamcount + 2).Interior.ColorIndex = xlCILightGreen
#End If
For j = 1 To n
hc(j) = wsI.Cells(j + 1, col_in_player_skill)
#If I_Want_Colors Then
wsI.Range("A" & j + 1 & ":C" & j + 1).Interior.ColorIndex = xlCILightYellow
#End If
Next j
min_stdev = 1E+308
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_skills)).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) = _
IIf("" = wsI.Cells(1 + mina((i - 1) * playersperteam + j), col_in_player_name), _
"[Empty]", wsI.Cells(1 + mina((i - 1) * playersperteam + j), col_in_player_name))
wsI.Cells(1 + (i - 1) * playersperteam + j, col_out_player_skill) = _
CDbl(wsI.Cells(1 + mina((i - 1) * playersperteam + j), col_in_player_skill))
s = s + wsI.Cells(1 + mina((i - 1) * playersperteam + j), col_in_player_skill)
#If I_Want_Colors Then
wsI.Range("I" & 1 + (i - 1) * playersperteam + j & ":K" & 1 + (i - 1) * _
playersperteam + j).Interior.ColorIndex = xlCILightGreen
#End If
Next j
wsI.Cells(1 + i, col_stat_team_no) = i
wsI.Cells(1 + i, col_stat_sum_skills) = s
#If I_Want_Colors Then
wsI.Range("M" & i + 1 & ":N" & i + 1).Interior.ColorIndex = xlCILightGreen
#End If
Next i
wsI.Cells(2 + teamcount, col_stat_team_no) = "StDev"
wsI.Cells(2 + teamcount, col_stat_sum_skills) = min_stdev
End Sub
Bitte den Haftungsausschluss im Impressum beachten.
sbGenerateTeams.xlsm [46 KB Excel Datei, Download und Nutzung auf eigene Gefahr]