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

## Abstract

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.

## Example

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.

``````Option Explicit

Enum TeamColums
tc_Date = 1
tc_TeamStart
End Enum

Enum AllocationColumns
ac_Date = 1
ac_Demand
ac_Comment
ac_TeamStart
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
Loop
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
Else
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)

Loop

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

End With

End Sub
``````