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:

sbGenerateTeams_Screen

Dieses Programm vereint mehrere Funktionalitäten, die ich gern nutze:

  1. Die Klasse SystemState reduziert die Laufzeit.

  2. 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.

  3. Neues Mischen einer Menge von Elementen mit UniqRandInt.

  4. 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]