“Necessity is the mother of taking chances.” [Mark Twain]
Abstract
You need to distribute a collection of items to some collectors in a fair way? And you do not know priorities of the collectors for all items, you just know how many the collectors like to have and (maybe) how much they are worth?
Even then you can still distribute the items fairly by chance (randomly). The likelihoods for the distribution can be set by item count or by total values of items. Any winner of an item will get his/her item count and/or total value reduced for the next draw.
Example: Distributing a Coin Collection
We like to distribute 10 coins to 5 collectors fairly.
First we enter our data into tab Input or we let it get generated randomly:
In case we have as many coins as all collectors like to have together, we have no issue:
There are some cases though, where we have less coins than requested:
Our challenge is to solve these conflicts fairly. We have many options to set the likelihoods for a random distribution, for example:
- 1 = Random distribution according to item count
- 2 = Random distribution according to item value
- 3 = Random sort of conflicts, then count distribution (higher count wins)
- 4 = Random sort of conflicts, then total value distribution (higher value wins)
- 5 = Random distribution with equal chances
- 6 = Like 3 but small count wins
- 7 = Like 1 but start with equal chances and reduce them when an item is won
A program can quickly perform random draws but it is advisable to make the process reviewable so that the collectors can trust it.
If we choose the order of collectors randomly and if the program sorts the conflicts randomly, we can solve the conflicts by selecting the items according to their total value (option 4 above):
The program documents its execution steps and its decisions automatically as follows (extract of program log):
Items: 10, Collectors: 5, Distribution Type: 4
Solution for conflict of Item 6, copy 1 is collector 5 because of first weight maximum in Collector|Weight: 3|2010, 5|5850
Solution for conflict of Item 6, copy 2 is collector 5 because of first weight maximum in Collector|Weight: 3|2010, 5|4440
Solution for conflict of Item 9, copy 1 is collector 5 because of first weight maximum in Collector|Weight: 1|1810, 2|950, 5|3030
Solution for conflict of Item 9, copy 2 is collector 5 because of first weight maximum in Collector|Weight: 1|1810, 2|950, 5|2080
Solution for conflict of Item 9, copy 3 is collector 1 because of first weight maximum in Collector|Weight: 1|1810, 2|950, 5|1130
Solution for conflict of Item 5 is collector 3 because of first weight maximum in Collector|Weight: 3|2010, 4|1160
Solution for conflict of Item 10 is collector 4 because of first weight maximum in Collector|Weight: 1|860, 4|1160
Solution for conflict of Item 8 is collector 5 because of first weight maximum in Collector|Weight: 4|540, 5|1130
Solution for conflict of Item 1 is collector 3 because of first weight maximum in Collector|Weight: 1|860, 3|1650
Collector | Conflicts | Thereof unsolved | Value Sum | Thereof unsolved
1 | 3 | 2 | 1.810 | 860
2 | 1 | 1 | 950 | 950
3 | 3 | 1 | 2.010 | 1.410
4 | 3 | 2 | 1.160 | 540
5 | 6 | 1 | 5.850 | 950
Program Elements
The program presented here contains some elements which I like to use:
The class SystemState stores system status variables and sets them to speed up program execution in a simple manner.
If possible the program does not access single sheet cells repeatedly. It stores sheet ranges with one command in variants, then applies calculations in main memory without sheet access and finally write the variants back into sheet ranges with another single command. This accelerates program execution enormously in case we need to deal with several thousand records.
With enumerations I organize access to worksheet columns flexibly - for additional columns or deleted columns I just amend the enumeration, and the program will re-adjust automatically.
Class Logger is not used here to test the program but for self documentation. The output explains in detail to the user which steps and which decisions the program took. To avoid slower execution speed the compiler constants were set to Logging_cashed = True and to Log_WMI_Info = False.
The function sbExactRandHistogrm I like to use to easily create random input data with exact distributions. It requires RoundToSum](https://www.sulprobil.de/roundtosum_en/ “RoundToSum”) just in case the exact requested distribution is not possible. Then it delivers a (rounded) proxy.
The function sbRandHistogrm is used with distribution type 1 and 2 for random selection. I could have used sbExactRandHistogrm instead but this function uses less resources.
Appendix – Code
Please note that this program needs (uses) classes SystemState, Logger and the functions RoundToSum, sbRandHistogrm, and sbExactRandHistogrm. These functions are contained in the file you can download below.
Please read my Disclaimer.
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_items
ic_itemvalue
ic_itemcount
ic_collector1
'ic_Ubound is ic_collector1 + lCollectors
End Enum
Public Const AppVersion As String = "Fair_Random_Distribution_of_Items_v0.2"
Public lItems 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_Step1_Create_Tab_Input()
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_Step1_Create_Tab_Input"
Application.StatusBar = "Create tab Input ..."
With Application.WorksheetFunction
Randomize
wsInput.Cells.ClearContents
lItems = Range("Items")
lCollectors = Range("Collectors")
GLogger.ever "Items: " & lItems & ", Collectors: " & lCollectors
vData = wsInput.Range(wsInput.Cells(1, ic_LBound + 1), _
wsInput.Cells(lItems + 1, ic_collector1 + lCollectors - 1)).Value
vData(1, ic_items) = "Items"
vData(1, ic_itemvalue) = "Est. Value"
vData(1, ic_itemcount) = "There are this many"
For i = 1 To lCollectors
vData(1, ic_collector1 - 1 + i) = "Collector " & i & " wants"
v = sbExactRandHistogrm(lItems, 0, 4, Array(8, 1, 1, 1))
For j = 2 To lItems + 1
vData(j, ic_collector1 - 1 + i) = Int(v(j - 1))
Next j
Next i
v = sbExactRandHistogrm(lItems, 1, 4, Array(8, 1, 1))
For j = 2 To lItems + 1
vData(j, ic_itemcount) = Int(v(j - 1))
Next j
For i = 1 To lItems
vData(1 + i, ic_items) = "Item " & i
vData(1 + i, ic_itemvalue) = Int(Rnd * 190) * 10 + 10
Next i
wsInput.Range(wsInput.Cells(1, ic_LBound + 1), _
wsInput.Cells(lItems + 1, ic_collector1 + lCollectors - 1)).Value = vData
wsInput.Columns.AutoFit
End With
End Sub
Sub Simulation_Step2_Calculate_Distribution()
Dim i As Long
Dim j As Long
Dim k As Long
Dim m As Long
Dim n As Long
Dim lItemCount As Long
Dim lItemRequest As Long
Dim lDistributionType As Long
Dim lRequest As Long
Dim dItemValue 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_Step2_Calculate_Distribution"
Application.StatusBar = "Fill tabs 'No_Issue' and 'Conflicts' ..."
With Application.WorksheetFunction
lItems = Range("Items")
lCollectors = Range("Collectors")
lDistributionType = Range("Distribution_Type")
GLogger.ever "Items: " & lItems & ", Collectors: " & lCollectors & _
", Distribution Type: " & lDistributionType
vData = wsInput.Range(wsInput.Cells(1, ic_LBound + 1), _
wsInput.Cells(lItems + 1, ic_collector1 + lCollectors - 1)).Value
vConflicts = vData
vNoProb = vData
lConflictCount = 0
lNoProbCount = 0
For i = 2 To lItems + 1
dItemValue = vData(i, ic_itemvalue)
lItemCount = vData(i, ic_itemcount)
lItemRequest = 0#
For j = ic_collector1 To ic_collector1 + lCollectors - 1
If vData(i, j) > lItemCount Then vData(i, j) = lItemCount
lItemRequest = lItemRequest + vData(i, j)
Next j
If lItemRequest > lItemCount 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_items), _
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_items), _
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 > 2 And lConflictCount > 1 Then
wsConflicts.Cells(1, ic_collector1 + lCollectors) = "Random Sort Key"
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_items), _
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_items), _
wsConflicts.Cells(1, ic_collector1 + lCollectors - 1)).Copy wsSolved.Range("A1")
If lConflictCount > 0 Then
'Count total sum and total values of requested conflict items for each collector
ReDim lTotalItemRequests(1 To lCollectors)
ReDim lTotalItemValues(1 To lCollectors)
For i = 1 To lConflictCount
lItemCount = vConflicts(i, ic_itemcount)
For j = ic_collector1 To ic_collector1 + lCollectors - 1
lRequest = vConflicts(i, j)
If lRequest > lItemCount Then
GLogger.info "Set item count for collector " & i & " from " & _
lRequest & " to " & lItemCount & " because there are no more"
lRequest = lItemCount
vConflicts(i, j) = lRequest
End If
lTotalItemRequests(j - ic_collector1 + 1) = _
lTotalItemRequests(j - ic_collector1 + 1) + lRequest
lTotalItemValues(j - ic_collector1 + 1) = _
lTotalItemValues(j - ic_collector1 + 1) + lRequest * vConflicts(i, ic_itemvalue)
Next j
Next i
ReDim lItemRequests(1 To lCollectors) As Long 'Copy of lTotalItemRequests which we count down
ReDim dWeight(1 To lCollectors) As Double
ReDim lItemValues(1 To lCollectors) As Long 'Copy of lTotalItemValues which we count down
For i = 1 To lCollectors
lItemRequests(i) = lTotalItemRequests(i)
lItemValues(i) = lTotalItemValues(i)
Next i
ReDim lThisItemRequest(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
lItemCount = vConflicts(i, ic_itemcount)
For k = 1 To lCollectors
vSolved(i, ic_collector1 + k - 1) = 0
Next k
For j = 1 To lItemCount
Select Case lDistributionType
Case 1, 2, 5, 7
'Load weights for random draw
s = "Collector|Weight: "
For k = 1 To lCollectors
If vConflicts(i, ic_collector1 + k - 1) > 0 Then
Select Case lDistributionType
Case 1
dWeight(k) = lItemRequests(k)
Case 2
dWeight(k) = lItemValues(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 "Solution for conflict of " & vConflicts(i, ic_items) & _
IIf(lItemCount > 1, ", copy " & j, "") & " is collector " & _
n & " because of random draw from " & Left(s, Len(s) - 2)
If lDistributionType = 7 Then
dOverallWeight(n) = dOverallWeight(n) * (lItemRequests(n) - 1#) / lItemRequests(n)
End If
Case 3, 4, 6
'Look for extreme weight
If lDistributionType = 6 Then
m = lItems + 1
Else
m = 0
End If
n = 0
s = "Collector|Weight: "
For k = 1 To lCollectors
If vConflicts(i, ic_collector1 + k - 1) > 0 Then
If lDistributionType = 3 Then
If m < lItemRequests(k) Then
m = lItemRequests(k)
n = k
End If
s = s & k & "|" & lItemRequests(k) & ", "
ElseIf lDistributionType = 6 Then
If m > lItemRequests(k) Then
m = lItemRequests(k)
n = k
End If
s = s & k & "|" & lItemRequests(k) & ", "
ElseIf lDistributionType = 4 Then
If m < lItemValues(k) Then
m = lItemValues(k)
n = k
End If
s = s & k & "|" & lItemValues(k) & ", "
End If
Else
dWeight(k) = 0
End If
Next k
GLogger.info "Solution for conflict of " & vConflicts(i, ic_items) & _
IIf(lItemCount > 1, ", copy " & j, "") & " is collector " & _
n & " because of first weight " & _
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
lItemRequests(n) = lItemRequests(n) - 1
lItemValues(n) = lItemValues(n) - vConflicts(i, ic_itemvalue)
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("Item requests with conflicts [count]", _
"Open requests after distribution [count]", _
"Item requests with conflicts [total value]", _
"Open requests after distribution [total value]"))
GLogger.info "Collector | Conflicts | Thereof unsolved | Value Sum | Thereof unsolved"
For i = 1 To lCollectors
wsCtrl.Cells(14, 7 + i) = "Collector " & i
wsCtrl.Cells(15, 7 + i) = lTotalItemRequests(i)
wsCtrl.Cells(16, 7 + i) = lItemRequests(i)
wsCtrl.Cells(17, 7 + i) = lTotalItemValues(i)
wsCtrl.Cells(18, 7 + i) = lItemValues(i)
GLogger.info Right(String(9, " ") & Format(i, "#,##0"), 9) & " | " & _
Right(String(9, " ") & Format(lTotalItemRequests(i), "#,##0"), 9) & " | " & _
Right(String(16, " ") & Format(lItemRequests(i), "#,##0"), 16) & " | " & _
Right(String(9, " ") & Format(lTotalItemValues(i), "#,##0"), 9) & " | " & _
Right(String(16, " ") & Format(lItemValues(i), "#,##0"), 16)
Next i
wsCtrl.Range("H15", wsCtrl.Cells(18, 7 + lCollectors)).NumberFormat = "#,##0_ ;[Red]-#,##0 "
Else
wsCtrl.Range("G14") = "No conflicts to solve"
End If
wsCtrl.Range("G:XFD").EntireColumn.AutoFit
End With
End Sub
Download
Please read my Disclaimer.
Fair_Random_Distribution_of_Items.xlsm [109 KB Excel file, open and use at your own risk]