“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.
Please read my Disclaimer.
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
Please read my Disclaimer.
sbFairStaffSelection.xlsm [51 KB Excel file, open and use at your own risk]