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