“A diverse team is not always better.” [Simone Menne]


Let us assume your company needs to get some special tasks done. All staff members can do the work. You want the teams to second their staff based on the size of each team.

This selection can be done by the user defined function RoundToSum.

Since we cannot guarantee that each team can provide staff exactly in relation to its staff number for each special task, we need to call RoundToSum including a lookback onto previous staff selections.

RoundToSum uses the largest remainder method (also called Hare-Niemeyer) which can suffer from the Alabama paradoxon. If the total number of staff to be selected increases it can happen that a team needs to provide less staff than before. Because we cannot account for this in hindsight, this paradoxon needs to be dealt with as soon as it occurs.


On 1-Jan-2023 these teams exist:


Over the following three months these staff numbers are required for special tasks and are selected:


On 1-Feb-2023 the largest remainder method would have selected a total number of 184, 125, 13, and 2 employees of teams A, B, C, and D ausgewählt. But on 1-Jan-2023 team C had already provided 14 members of staff which cannot be taken back. This means that team A or team B needs to provide one employee less. The implemented algorithm look left to right to account for this, so in this case team A is impacted.

On 1-Mar-2023 all remaining staff counts of all teams are requested. The algorithm selects for each team exactly its staff count in total because the lookback includes all request data records.

Appendix – sbFairStaffSelection Code

Please note: this function refers to (needs) RoundToSum.

Please read my Disclaimer.

Option Explicit

Enum TeamColums
    tc_Date = 1
End Enum

Enum AllocationColumns
    ac_Date = 1
End Enum

Sub sbFairStaffSelection()
'Based on the weights defined in tab Teams this program allocates
'a "fair" selection (the number given in column Demand of tab
'Allocation) of staff from these teams. This program uses (calls) RoundToSum
'which applies the largest remainder method, so the Alabama paradoxon
'must be taken care of. It also applies a lookback up to the topmost
'allocation data row.
'In case of negative selection counts (i. e. the Alabama paradoxon)
'the negative values will be set to zero and the necessary amendments
'(reductions) will be applied from left to right. Please order your
'teams with ascending sizes or descending sizes to account for this.
'Source (EN): https://www.sulprobil.com/sbfairstaffselection_en
'Source (DE): https://www.bplumhoff.com/sbfairstaffselection_de
'(C) (P) by Bernd Plumhoff 09-Mar-2023 PB V0.1

Dim bLookBack                As Boolean
Dim bReCalc                  As Boolean

Dim i                        As Long
Dim j                        As Long
Dim k                        As Long
Dim m                        As Long
Dim lAmend                   As Long
Dim lCellResult              As Long
Dim lDemand                  As Long
Dim lRowSum                  As Long
Dim lSum                     As Long
Dim lTotal                   As Long 'Most recent total number of staff in all teams

Dim sComment                 As String

Dim vAlloc                   As Variant
Dim vTeams                   As Variant

Dim state                    As SystemState

Set state = New SystemState

With Application.WorksheetFunction

vTeams = .Transpose(.Transpose(Range(wsT.Cells(1, 1).End(xlDown).Offset(0, tc_TeamStart - 1), _
          wsT.Cells(1, 1).End(xlDown).End(xlToRight))))
j = UBound(vTeams)
ReDim dAlloc(1 To j) As Double
lTotal = .Sum(vTeams)

bReCalc = False
i = 2
lDemand = wsA.Cells(i, ac_Demand)
Do While lDemand > 0

    lRowSum = .Sum(Range(wsA.Cells(i, ac_TeamStart), wsA.Cells(i, ac_TeamStart + j)))
    If lDemand <> lRowSum Then bReCalc = True
    If bReCalc Or wsA.Cells(i + 1, ac_Demand) = 0 Then
        sComment = "Recalc " & Format(Now(), "DD.MM.YYYY HH:nn:ss") & ". "
        bLookBack = False
        k = i - 1
        If k > 1 Then
            bLookBack = True
            lDemand = 0
            lSum = 0
            ReDim lTeamSum(1 To j) As Long
            Do While k > 1
                lSum = lSum + wsA.Cells(k, ac_Demand)
                lDemand = wsA.Cells(i, ac_Demand) + lSum
                For m = 1 To j
                    lTeamSum(m) = lTeamSum(m) + wsA.Cells(k, m + ac_TeamStart - 1)
                Next m
                'If lSum >= lTotal Then Exit Do 'Uncomment if lookback should be restricted
                                                'to total staff number
                k = k - 1
        End If
        For m = 1 To j
            dAlloc(m) = lDemand * vTeams(m) / lTotal
        Next m
        vAlloc = RoundToSum(vInput:=dAlloc, lDigits:=0)
        If bLookBack Then
            For m = 1 To j
                lCellResult = vAlloc(m) - lTeamSum(m)
                If lCellResult < 0 Then
                    'The Alabama Paradoxon: we have to reduce other parties'
                    'allocations because we cannot have negative allocations
                    lAmend = lAmend - lCellResult
                End If
                vAlloc(m) = lCellResult
            Next m
            If lAmend > 0 Then
                For m = 1 To j
                    lCellResult = vAlloc(m)
                    If lCellResult < 0 Then
                        vAlloc(m) = 0
                        sComment = sComment & "Allocation for " & m & " set to 0. "
                    ElseIf lCellResult > 0 And lAmend > 0 Then
                        If lCellResult > lAmend Then
                            vAlloc(m) = lCellResult - lAmend
                            lAmend = 0
                            vAlloc(m) = 0
                            lAmend = lAmend - lCellResult
                        End If
                        sComment = sComment & "Allocation for " & m & " amended to " & _
                                   vAlloc(m) & ". "
                    End If
                Next m
            End If
        End If
        wsA.Cells(i, ac_Comment) = sComment
        For m = 1 To j
            wsA.Cells(i, ac_TeamStart + m - 1) = vAlloc(m)
        Next m
    End If
    i = i + 1
    lDemand = wsA.Cells(i, ac_Demand)

Range(wsT.Cells(1, tc_TeamStart), wsT.Cells(1, 250)).Copy Destination:=wsA.Cells(1, ac_TeamStart)

End With

End Sub

Please read my Disclaimer.

sbFairStaffSelection.xlsm [51 KB Excel file, open and use at your own risk]