“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.
Zunächst geben wir die Daten in das Tabellenblatt Eingabe ein oder lassen sie zufällig durch eine Simulation erzeugen:
Wenn wir mindestens so viele Münzen haben, wie alle Sammler zusammen bekommen möchten, haben wir kein Problem:
Es gibt jedoch einige Fälle, bei denen weniger Münzen vorliegen als gewünscht werden:
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:
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.bplumhoff.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.com/fair_random_distribution_en/
'Source (DE): http://www.bplumhoff.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]