“For many people my software is something that you install and forget. I like to keep it that way.” [Wietse Venema]

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 möglichst gleichstark aufstellen können?

So kann man dies erreichen:

sbGenerateTeams_4Teams

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.

Ein komplexeres Beispiel

Falls Sie zufällige Teams gleicher Stärke generieren möchten, die Untergruppen verschiedener Spielerarten haben, können Sie Spielstärkewerte mit unterschiedlichen Zehnerpotenzen (oder andere Potenzen) je Untergruppe vergeben. Sie müssen lediglich darauf achten, dass alle Untergruppen in allen Teams dieselbe Spieleranzahl haben - Ausnahme: die Untergruppe mit den kleinsten Spielstärkewerten kann unterschiedlich viele Spieler in den Teams haben:

sbGenerateTeams_Soccer

Sie können nach einem Spiel die Spielstärkewerte anpassen. Zum Beispiel könnten Sie die Werte der Gewinner um 1 erhöhen, bis ein Maximalwert je Untergruppe erreicht ist. Oder Sie verringern die Werte für die Verlierer um 1, bis ein Minimalwert je Untergruppe erreicht ist. So stellen Sie sicher, dass auch Spielstärkeänderungen fair und nachvollziehbar abgebildet werden.

Appendix – Programmcode sbGenerateTeams

Bitte beachten: Dieses Programm benötigt (verwendet) die Klasse SystemState und die benutzerdefinierte Funktion UniqRandInt.

Bitte den Haftungsausschluss im Impressum beachten.

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 UniqRandInt - google for sulprobil and uniqrandint.
'and the SystemState class - google for sulprobil and systemstate.
'Source (EN): https://www.sulprobil.de/sbgenerateteams_en/
'Source (DE): https://www.berndplumhoff.de/sbgenerateteams_de/
'(C) (P) by Bernd Plumhoff 07-Nov-2024 PB V0.5

Dim i                   As Long
Dim j                   As Long
Dim k                   As Long
Dim n                   As Long
Dim teamcount           As Long
Dim playersperteam      As Long
Dim stdev_hc_sum        As Double
Dim 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 = ThisWorkbook.ActiveSheet
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 = UniqRandInt(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

Download

Bitte den Haftungsausschluss im Impressum beachten.

sbGenerateTeams.xlsm [62 KB Excel Datei, Download und Nutzung auf eigene Gefahr]