“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.

Fair_Random_Distribution_Control

First we enter our data into tab Input or we let it get generated randomly:

Fair_Random_Distribution_Input

In case we have as many coins as all collectors like to have together, we have no issue:

Fair_Random_Distribution_No_Issue

There are some cases though, where we have less coins than requested:

Fair_Random_Distribution_Conflicts

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):

Fair_Random_Distribution_Conflicts_Solved

Fair_Random_Distribution_Stats

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]