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

Abstract

You and your 15 friends want to play in teams of 4 and you wonder how to come up with a fair distribution of teams, because each player has an individual skill level?

Here you go:

sbGenerateTeams_4Teams

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.

A More Complex Example

In case you need to fairly generate random teams which consist of different player groups, you can apply different powers of 10 (or other values) for their skills. Then you just need to be aware of different player numbers in each team. All subgroups of the teams should have the same player numbers. Just the last one with the smallest skill values can be uneven:

sbGenerateTeams_Soccer

You can even change the skill values after each match. Increase the skill values of players who have won (up to some certain value) and decrease the skill levels of those who lost (down to some other limit value). This is one way to ensure that changes of skills are fairly and comprehensibly represented.

Appendix – sbGenerateTeams Code

Please note: This program needs (uses) class SystemState and the user-defined function VBUniqRandInt.

Please read my Disclaimer.

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 to 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.de/sbgenerateteams_en/
'Source (DE): http://www.berndplumhoff.de/sbgenerateteams_de/
'(C) (P) by Bernd Plumhoff 26-Nov-2023 PB V0.4

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 = 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

Please read my Disclaimer.

sbGenerateTeams.xlsm [56 KB Excel file, open and use at your own risk]