“Eine schöne Kombination auf dem Fußballplatz ergibt sich nicht einfach so. Schönheit ist die Abwesenheit von Zufällen.” [Felix Magath]

Abstract

Sie wollen eine Menge von Gegenständen fair an eine Menge von Sammlern verteilen? Und Sie kennen keine Prioritäten der Sammler für alle Gegenstände, sondern wissen lediglich, wie viele Exemplare die Sammler jeweils haben wollen und ggf. wieviel sie wert sind?

Dann können Sie immer noch fair nach dem Zufallsprinzip verteilen. Dabei können die Wahrscheinlichkeiten für die Verteilung sich nach der Anzahl der gewünschten Gegenstände oder nach ihrer Wertsumme richten, wobei für den Gewinner einer jeden Verlosung die künftige Wahrscheinlichkeit um die gewonnene Stückzahl oder deren Wert reduziert wird.

Beispiel: Auflösung einer Münzsammlung

Wir wollen 10 Münzen fair an 5 Sammler verteilen.

Münzsammlung_auflösen_Steuerung

Zunächst geben wir die Daten in das Tabellenblatt Eingabe ein oder lassen sie zufällig durch eine Simulation erzeugen:

Münzsammlung_Eingabe

Wenn wir mindestens so viele Münzen haben, wie alle Sammler zusammen bekommen möchten, haben wir kein Problem:

Münzsammlung_Kein_Problem

Es gibt jedoch einige Fälle, bei denen weniger Münzen vorliegen als gewünscht werden:

Münzsammlung_Konflikte

Unsere Herausforderung liegt darin, diese Konflikte fair aufzulösen. Dabei bietet sich eine Vielzahl von Möglichkeiten, die Wahrscheinlichkeiten für eine zufällige Verteilung festzulegen, zum Beispiel:

  • 1 = Verteilung nach Münzwunschanzahl
  • 2 = Verteilung nach Münzwert
  • 3 = Zufalls-Sort der Konflikte + Verteilung nach Anzahl (hohe Zahl gewinnt)
  • 4 = Zufalls-Sort der Konflikte + Verteilung nach Wert (hoher Wert gewinnt)
  • 5 = Losverteilung mit gleichen Chancen
  • 6 = Wie 3 aber kleine Anzahl gewinnt
  • 7 = Wie 1 aber ausgehend von gleichen Chancen, die durch Münzgewinn reduziert werden

Ein Programm kann viele zufällige Verlosungen rasch durchführen, aber es ist bestimmt ratsam, das gewählte Verfahren nachvollziehbar zu machen, damit die betroffenen Personen ihm auch vertrauen können.

Wenn man die Reihenfolge der Sammler zufällig wählt, und das Programm die Eingabezeilen zufällig anordnen lässt, können zum Beispiel die Konflikte nach der Wertsumme der gewünschten Münzen (obige Option 4) aufgelöst werden:

Münzsammlung_Konfliktlösung

Münzsammlung_Stats

Das Programm dokumentiert seine Schritte und Entscheidungen automatisch selbst wie folgt (Extrakt des Programmlogs):

Münzen: 10, Sammler: 5, Verteilungsart: 4
Konfliktlösung für Münze 10 ist Sammler 5 wegen erstem Gewichtmaximum in Sammler|Gewicht: 1|2830, 3|3350, 4|3490, 5|5490
Konfliktlösung für Münze 7 ist Sammler 3 wegen erstem Gewichtmaximum in Sammler|Gewicht: 1|2830, 3|3350
Konfliktlösung für Münze 8 ist Sammler 4 wegen erstem Gewichtmaximum in Sammler|Gewicht: 2|1920, 4|3490
Konfliktlösung für Münze 9 ist Sammler 3 wegen erstem Gewichtmaximum in Sammler|Gewicht: 2|1920, 3|2310
Konfliktlösung für Münze 1, Exemplar 1 ist Sammler 5 wegen erstem Gewichtmaximum in Sammler|Gewicht: 4|2650, 5|3700
Konfliktlösung für Münze 1, Exemplar 2 ist Sammler 5 wegen erstem Gewichtmaximum in Sammler|Gewicht: 4|2650, 5|2840
Konfliktlösung für Münze 1, Exemplar 3 ist Sammler 4 wegen erstem Gewichtmaximum in Sammler|Gewicht: 4|2650, 5|1980
Konfliktlösung für Münze 2, Exemplar 1 ist Sammler 5 wegen erstem Gewichtmaximum in Sammler|Gewicht: 2|1920, 5|1980
Konfliktlösung für Münze 2, Exemplar 2 ist Sammler 2 wegen erstem Gewichtmaximum in Sammler|Gewicht: 2|1920, 5|1420
Sammler | Konfliktanzahl | Davon unerfüllt | Wertsumme | Davon unerfüllt
      1 |              2 |               2 |     2.830 |           2.830
      2 |              3 |               2 |     1.920 |           1.360
      3 |              3 |               1 |     3.350 |           1.790
      4 |              3 |               1 |     3.490 |           1.790
      5 |              6 |               2 |     5.490 |           1.420

Programmelemente

Das vorgestellte Programm beinhaltet einige von mir gern verwendete Elemente:

Die Klasse SystemState speichert und setzt mehrere Systemstatusvariablen, um die Programmausführung auf einfache Weise zu beschleunigen.

Nach Möglichkeit greift das Programm nicht ständig auf einzelne Tabellenzellen zu, sondern speichert ganze Tabellenbereiche mit einem Befehl in Variant Variablen, rechnet anschließend mit diesen Bereichen im Hauptspeicher und schreibt die Ergebnisse am Ende wieder mit einem Befehl aus den Variant Variablen in die Excel Tabellen zurück. Die hat bei mehreren Tausend Datensätzen enorme Geschwindigkeitsvorteile.

Mit dem Aufzählungs Typ Enum organisiere ich den flexiblen Zugriff auf Tabellenspalten - für zusätzliche oder entfallende Spalten ändere ich lediglich die Aufzählung, und das Programm passt sich danach automatisch an.

Die Klasse Logger wird hier nicht zum Testen der Anwendung eingesetzt, sondern zur Selbstdokumentation. Die ausgegebenen Daten erklären dem Anwender im Detail, welche Schritte und welche Entscheidungen das Programm durchführte. Dabei wurden die Compilerkonstanten Logging_cashed = True und Log_WMI_Info = False gesetzt, um das Programm nicht zu verlangsamen.

Die Funktion sbExactRandHistogrm verwende ich gern für die zufällige Erzeugung von Eingabedaten, weil ich die genaue Verteilungen vorgeben kann. Sie benötigt die Funktion RoundToSum](https://www.berndplumhoff.de/roundtosum_de/ “RoundToSum”) lediglich, wenn die gewünschte Verteilung nicht exakt erreicht werden kann - dann wird halt genähert.

Die Funktion sbRandHistogrm wird für die Zufallsauswahl bei den Verteilungsarten 1 und 2 verwendet. An ihrer Stelle hätte auch sbExactRandHistogrm eingesetzt werden können, aber diese Funktion ist deutlich weniger aufwendig.

Appendix – Programmcode

Bitte beachten Sie, dass dieses Programm die Klassen SystemState und Logger sowie die Funktionen RoundToSum, sbRandHistogrm und sbExactRandHistogrm benötigt und aufruft. Diese Funktionen sind in der u. g. Beispieldatei enthalten.

Bitte den Haftungsausschluss im Impressum beachten.

Option Explicit

'Creates a fair random distribution.
'Source (EN): http://www.sulprobil.de/fair_random_distribution_en/
'Source (DE): http://www.berndplumhoff.de/fair_zufaellig_verteilen_de/
'(C) (P) by Bernd Plumhoff 7-Dec-2023 PB V0.4

Enum mc_Macro_Categories
    mcFinancial = 1
    mcDate_and_Time
    mcMath_and_Trig
    mcStatistical
    mcLookup_and_Reference
    mcDatabase
    mcText
    mcLogical
    mcInformation
    mcCommands
    mcCustomizing
    mcMacro_Control
    mcDDE_External
    mcUser_Defined
    mcFirst_custom_category
    mcSecond_custom_category 'and so on
End Enum 'mc_Macro_Categories

Public Enum Input_Columns
    ic_LBound = 0
    ic_coins
    ic_coinvalue
    ic_coincount
    ic_collector1
    'ic_Ubound is ic_collector1 + lCollectors
End Enum

Public Const AppVersion  As String = "Faire_Auflösung_einer_Münzsammlung_v0.2"
Public lCoins            As Long
Public lCollectors       As Long
Public lConflictCount    As Long
Public lNoProbCount      As Long
Public vConflicts        As Variant
Public vData             As Variant
Public vNoProb           As Variant

Sub Simulation_Schritt1_Blatt_Eingabe_erzeugen()

Dim i                    As Long
Dim j                    As Long
Dim v                    As Variant
Dim state                As SystemState

Set state = New SystemState
If GLogger Is Nothing Then Start_Log
GLogger.SubName = "Simulation_Schritt1_Blatt_Eingabe_erzeugen"
Application.StatusBar = "Erzeuge Blatt Eingabe ..."
With Application.WorksheetFunction
Randomize
wsInput.Cells.ClearContents
lCoins = Range("Münzen")
lCollectors = Range("Sammler")
GLogger.ever "Münzen: " & lCoins & ", Sammler: " & lCollectors
vData = wsInput.Range(wsInput.Cells(1, ic_LBound + 1), _
        wsInput.Cells(lCoins + 1, ic_collector1 + lCollectors - 1)).Value
vData(1, ic_coins) = "Münzen"
vData(1, ic_coinvalue) = "Schätzwert"
vData(1, ic_coincount) = "Wieviel gibt es davon"
For i = 1 To lCollectors
    vData(1, ic_collector1 - 1 + i) = "Soviel will Sammler " & i
    v = sbExactRandHistogrm(lCoins, 0, 4, Array(8, 1, 1, 1))
    For j = 2 To lCoins + 1
        vData(j, ic_collector1 - 1 + i) = Int(v(j - 1))
    Next j
Next i
v = sbExactRandHistogrm(lCoins, 1, 4, Array(8, 1, 1))
For j = 2 To lCoins + 1
    vData(j, ic_coincount) = Int(v(j - 1))
Next j
For i = 1 To lCoins
    vData(1 + i, ic_coins) = "Münze " & i
    vData(1 + i, ic_coinvalue) = Int(Rnd * 190) * 10 + 10
Next i
wsInput.Range(wsInput.Cells(1, ic_LBound + 1), _
    wsInput.Cells(lCoins + 1, ic_collector1 + lCollectors - 1)).Value = vData
wsInput.Columns.AutoFit
End With
End Sub

Sub Simulation_Schritt2_Verteilung_berechnen()

Dim i                    As Long
Dim j                    As Long
Dim k                    As Long
Dim m                    As Long
Dim n                    As Long
Dim lCoinCount           As Long
Dim lCoinRequest         As Long
Dim lDistributionType    As Long
Dim lRequest             As Long
Dim dCoinValue           As Double
Dim s                    As String
Dim vSolved              As Variant
Dim state                As SystemState

Set state = New SystemState
Randomize
If GLogger Is Nothing Then Start_Log
GLogger.SubName = "Simulation_Schritt2_Verteilung_berechnen"
Application.StatusBar = "Fülle Blätter 'Kein_Problem' und 'Konflikte' ..."
With Application.WorksheetFunction
lCoins = Range("Münzen")
lCollectors = Range("Sammler")
lDistributionType = Range("Verteilungsart")
GLogger.ever "Münzen: " & lCoins & ", Sammler: " & lCollectors & _
             ", Verteilungsart: " & lDistributionType
vData = wsInput.Range(wsInput.Cells(1, ic_LBound + 1), _
        wsInput.Cells(lCoins + 1, ic_collector1 + lCollectors - 1)).Value
vConflicts = vData
vNoProb = vData
lConflictCount = 0
lNoProbCount = 0
For i = 2 To lCoins + 1
    dCoinValue = vData(i, ic_coinvalue)
    lCoinCount = vData(i, ic_coincount)
    lCoinRequest = 0#
    For j = ic_collector1 To ic_collector1 + lCollectors - 1
        If vData(i, j) > lCoinCount Then vData(i, j) = lCoinCount
        lCoinRequest = lCoinRequest + vData(i, j)
    Next j
    If lCoinRequest > lCoinCount Then
        lConflictCount = lConflictCount + 1
        For j = 1 To ic_collector1 + lCollectors - 1
            vConflicts(lConflictCount, j) = vData(i, j)
        Next j
    Else
        lNoProbCount = lNoProbCount + 1
        For j = 1 To ic_collector1 + lCollectors - 1
            vNoProb(lNoProbCount, j) = vData(i, j)
        Next j
    End If
Next i

wsNoProb.Cells.ClearContents
wsInput.Range(wsInput.Cells(1, ic_coins), _
    wsInput.Cells(1, ic_collector1 + lCollectors - 1)).Copy wsNoProb.Range("A1")
If lNoProbCount > 0 Then
    wsNoProb.Range(wsNoProb.Cells(2, ic_LBound + 1), _
        wsNoProb.Cells(lNoProbCount + 1, ic_collector1 + lCollectors - 1)).Value = vNoProb
End If
wsNoProb.Columns.AutoFit

wsConflicts.Cells.ClearContents
wsInput.Range(wsInput.Cells(1, ic_coins), _
    wsInput.Cells(1, ic_collector1 + lCollectors - 1)).Copy wsConflicts.Range("A1")
If lConflictCount > 0 Then
    wsConflicts.Range(wsConflicts.Cells(2, ic_LBound + 1), _
        wsConflicts.Cells(lConflictCount + 1, ic_collector1 + lCollectors - 1)).Value = vConflicts
    wsConflicts.Columns.AutoFit
    
    If (lDistributionType = 3 Or lDistributionType = 4 Or lDistributionType = 6) And lConflictCount > 1 Then
        wsConflicts.Cells(1, ic_collector1 + lCollectors) = "Zufalls-Sortierschlüssel"
        ReDim r(1 To lConflictCount) As Double
        For i = 1 To lConflictCount: r(i) = Rnd: Next i
        wsConflicts.Range(wsConflicts.Cells(2, ic_collector1 + lCollectors), _
            wsConflicts.Cells(lConflictCount + 1, ic_collector1 + lCollectors)).FormulaArray = .Transpose(r)
        wsConflicts.Sort.SortFields.Clear
        wsConflicts.Sort.SortFields.Add2 _
            Key:=Range(Cells(2, ic_collector1 + lCollectors), _
                Cells(lConflictCount + 1, ic_collector1 + lCollectors)), _
            SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        With wsConflicts.Sort
            .SetRange Range(Cells(1, ic_coins), _
                Cells(lConflictCount + 1, ic_collector1 + lCollectors))
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End If
End If
wsConflicts.Columns.AutoFit
vConflicts = wsConflicts.Range(wsConflicts.Cells(2, ic_LBound + 1), _
        wsConflicts.Cells(lConflictCount + 1, ic_collector1 + lCollectors - 1)).Value

wsSolved.Cells.ClearContents
wsConflicts.Range(wsConflicts.Cells(1, ic_coins), _
    wsConflicts.Cells(1, ic_collector1 + lCollectors - 1)).Copy wsSolved.Range("A1")
If lConflictCount > 0 Then
    'Count total sum and total values of requested conflict coins for each collector
    ReDim lTotalCoinRequests(1 To lCollectors)
    ReDim lTotalCoinValues(1 To lCollectors)
    For i = 1 To lConflictCount
        lCoinCount = vConflicts(i, ic_coincount)
        For j = ic_collector1 To ic_collector1 + lCollectors - 1
            lRequest = vConflicts(i, j)
            If lRequest > lCoinCount Then
                GLogger.info "Setze Anzahl gewünschter Münzen für Sammler " & i & " von " & _
                    lRequest & " auf " & lCoinCount & ", weil es nicht mehr gibt"
                lRequest = lCoinCount
                vConflicts(i, j) = lRequest
            End If
            lTotalCoinRequests(j - ic_collector1 + 1) = _
                lTotalCoinRequests(j - ic_collector1 + 1) + lRequest
            lTotalCoinValues(j - ic_collector1 + 1) = _
                lTotalCoinValues(j - ic_collector1 + 1) + lRequest * vConflicts(i, ic_coinvalue)
        Next j
    Next i
    
    ReDim lCoinRequests(1 To lCollectors) As Long 'Copy of lTotalCoinRequests which we count down
    ReDim dWeight(1 To lCollectors) As Double
    ReDim lCoinValues(1 To lCollectors) As Long 'Copy of lTotalCoinValues which we count down
    For i = 1 To lCollectors
        lCoinRequests(i) = lTotalCoinRequests(i)
        lCoinValues(i) = lTotalCoinValues(i)
    Next i
    
    ReDim lThisCoinRequest(1 To lCollectors)
    vSolved = vConflicts
    If lDistributionType = 7 Then
        ReDim dOverallWeight(1 To lCollectors) As Double
        For k = 1 To lCollectors
            dOverallWeight(k) = 1#
        Next k
    End If
    For i = 1 To lConflictCount
        lCoinCount = vConflicts(i, ic_coincount)
        For k = 1 To lCollectors
            vSolved(i, ic_collector1 + k - 1) = 0
        Next k
        For j = 1 To lCoinCount
            Select Case lDistributionType
            Case 1, 2, 5, 7
                'Load weights for random draw
                s = "Sammler|Gewicht: "
                For k = 1 To lCollectors
                    If vConflicts(i, ic_collector1 + k - 1) > 0 Then
                        Select Case lDistributionType
                        Case 1
                            dWeight(k) = lCoinRequests(k)
                        Case 2
                            dWeight(k) = lCoinValues(k)
                        Case 5
                            dWeight(k) = 1#
                        Case 7
                            dWeight(k) = dOverallWeight(k)
                        End Select
                        s = s & k & "|" & dWeight(k) & ", "
                    Else
                        dWeight(k) = 0#
                    End If
                Next k
                'Execute random draw
                n = Int(sbRandHistogrm(1#, CDbl(lCollectors + 1#), CVar(dWeight)))
                GLogger.info "Konfliktlösung für " & vConflicts(i, ic_coins) & _
                    IIf(lCoinCount > 1, ", Exemplar " & j, "") & " ist Sammler " & _
                    n & " wegen Zufallsauswahl aus " & Left(s, Len(s) - 2)
                If lDistributionType = 7 Then
                    dOverallWeight(n) = dOverallWeight(n) * (lCoinRequests(n) - 1#) / lCoinRequests(n)
                End If
            Case 3, 4, 6
                'Look for extreme weight
                If lDistributionType = 6 Then
                    m = lCoins + 1
                Else
                    m = 0
                End If
                n = 0
                s = "Sammler|Gewicht: "
                For k = 1 To lCollectors
                    If vConflicts(i, ic_collector1 + k - 1) > 0 Then
                        If lDistributionType = 3 Then
                            If m < lCoinRequests(k) Then
                                m = lCoinRequests(k)
                                n = k
                            End If
                            s = s & k & "|" & lCoinRequests(k) & ", "
                        ElseIf lDistributionType = 6 Then
                            If m > lCoinRequests(k) Then
                                m = lCoinRequests(k)
                                n = k
                            End If
                            s = s & k & "|" & lCoinRequests(k) & ", "
                        ElseIf lDistributionType = 4 Then
                            If m < lCoinValues(k) Then
                                m = lCoinValues(k)
                                n = k
                            End If
                            s = s & k & "|" & lCoinValues(k) & ", "
                        End If
                    Else
                        dWeight(k) = 0
                    End If
                Next k
                GLogger.info "Konfliktlösung für " & vConflicts(i, ic_coins) & _
                    IIf(lCoinCount > 1, ", Exemplar " & j, "") & " ist Sammler " & _
                    n & " wegen erstem Gewichts" & _
                    IIf(lDistributionType = 6, "minimum", "maximum") & _
                    " in " & Left(s, Len(s) - 2)
            End Select
            vSolved(i, ic_collector1 + n - 1) = vSolved(i, ic_collector1 + n - 1) + 1
            vConflicts(i, ic_collector1 + n - 1) = vConflicts(i, ic_collector1 + n - 1) - 1
            lCoinRequests(n) = lCoinRequests(n) - 1
            lCoinValues(n) = lCoinValues(n) - vConflicts(i, ic_coinvalue)
        Next j
    Next i
    wsSolved.Range(wsSolved.Cells(2, ic_LBound + 1), _
        wsSolved.Cells(lConflictCount + 1, ic_collector1 + lCollectors - 1)).Value = vSolved
End If
wsSolved.Columns.AutoFit

'Fill stats
wsCtrl.Range("G:XFD").EntireColumn.Delete
If lConflictCount > 0 Then
    wsCtrl.Range("G15:G18").FormulaArray = .Transpose(Array("Münzwünsche mit Konflikt [Anzahl]", _
                                            "Unerfüllte Wünsche nach Verteilung [Anzahl]", _
                                            "Münzwünsche mit Konflikt [Wert]", _
                                            "Unerfüllte Wünsche nach Verteilung [Wert]"))
    GLogger.info "Sammler | Konfliktanzahl | Davon unerfüllt | Wertsumme | Davon unerfüllt"
    For i = 1 To lCollectors
        wsCtrl.Cells(14, 7 + i) = "Sammler " & i
        wsCtrl.Cells(15, 7 + i) = lTotalCoinRequests(i)
        wsCtrl.Cells(16, 7 + i) = lCoinRequests(i)
        wsCtrl.Cells(17, 7 + i) = lTotalCoinValues(i)
        wsCtrl.Cells(18, 7 + i) = lCoinValues(i)
        GLogger.info Right(String(7, " ") & Format(i, "#,##0"), 7) & " | " & _
            Right(String(14, " ") & Format(lTotalCoinRequests(i), "#,##0"), 14) & " | " & _
            Right(String(15, " ") & Format(lCoinRequests(i), "#,##0"), 15) & " | " & _
            Right(String(9, " ") & Format(lTotalCoinValues(i), "#,##0"), 9) & " | " & _
            Right(String(15, " ") & Format(lCoinValues(i), "#,##0"), 15)
    Next i
    wsCtrl.Range("H15", wsCtrl.Cells(18, 7 + lCollectors)).NumberFormat = "#,##0_ ;[Red]-#,##0 "
Else
    wsCtrl.Range("G14") = "Keinerlei Konflikte zu lösen"
End If
wsCtrl.Range("G:XFD").EntireColumn.AutoFit

End With
End Sub

Download

Bitte den Haftungsausschluss im Impressum beachten.

Faire_Auflösung_einer_Münzsammlung.xlsm [109 KB Excel Datei, ohne jegliche Gewährleistung]