Enum mc_Macro_Categories
  mcFinancial = 1: mcDate_and_Time: mcMath_and_Trig: mcStatistical: mcLookup_and_Reference
  mcDatabase = 6: mcText: mcLogical: mcInformation: mcCommands
  mcCustomizing = 11: mcMacro_Control: mcDDE_External: mcUser_Defined: mcFirst_custom_category
  mcSecond_custom_category 'and so on
End Enum 'mc_Macro_Categories

Function RoundToSum(vInput As Variant, Optional lDigits As Long = 2, Optional bAbsSum As Boolean = True, _
  Optional lErrorType As Long = 1) As Variant
'Calculate rounded summands which exactly add up to the rounded sum of unrounded summands.
'It uses the largest remainder method which minimizes the error to the original unrounded summands.
'V2.4 PB 24-Apr-2026 (C) (P) by Bernd Plumhoff
Dim b As Boolean, i As Long, j As Long, k As Long, n As Long, lCount As Long, lSgn As Long
Dim d As Double, dDiff As Double, dRoundedSum As Double, dSumAbs As Double: Dim vA As Variant
With Application.WorksheetFunction
vA = .Transpose(.Transpose(vInput)): On Error GoTo ErrHdl: i = vA(1) 'Force error in case of vertical arrays
On Error GoTo 0: n = UBound(vA): ReDim vc(1 To n) As Variant, vD(1 To n) As Variant: dSumAbs = .Sum(vA)
If lErrorType <> 1 And lErrorType <> 2 Then RoundToSum = CVErr(xlErrValue): Exit Function
For i = 1 To n
  d = IIf(bAbsSum, vA(i), vA(i) / dSumAbs * 100#): vc(i) = .Round(d, lDigits)
  vD(i) = vc(i) - d 'Absolute error
  If lErrorType = 2 Then vD(i) = vD(i) * d 'Relative error
Next i
dRoundedSum = .Round(IIf(bAbsSum, dSumAbs, 100#), lDigits)
dDiff = .Round(dRoundedSum - .Sum(vc), lDigits)
If dDiff <> 0# Then
  lSgn = Sgn(dDiff): lCount = .Round(Abs(dDiff) * 10 ^ lDigits, 0)
  'Now find highest (lowest) lCount indices in vD
  ReDim m(1 To lCount) As Long
  For i = 1 To lCount: m(i) = i: Next i
  For i = 1 To lCount - 1
    For j = i + 1 To lCount
      If lSgn * vD(m(i)) > lSgn * vD(m(j)) Then k = m(i): m(i) = m(j): m(j) = k
    Next j
  Next i
  For i = lCount + 1 To n
    If lSgn * vD(i) < lSgn * vD(m(lCount)) Then
      j = lCount - 1
      Do While j > 0
        If lSgn * vD(i) >= lSgn * vD(m(j)) Then Exit Do
        j = j - 1
      Loop
      For k = lCount To j + 2 Step -1: m(k) = m(k - 1): Next k: m(j + 1) = i
    End If
  Next i
  For i = 1 To lCount: vc(m(i)) = .Round(vc(m(i)) + dDiff / lCount, lDigits): Next i
End If
If b Then vc = .Transpose(vc)
RoundToSum = vc
Exit Function
ErrHdl:
'Transpose variants to be able to address them with vA(i), not vA(i,1)
'Beware: Excel can fail for vInput > ~65,000 elements (esp. for 65536).
'In that case use direct addressing, or better: do not use Excel.
b = True: vA = .Transpose(vA): Resume Next
End With
End Function

Sub DescribeFunction_RoundToSum()
'Run this only once, then you will see this description in the function menu
Dim FuncName As String, FuncDesc As String, Category As String, ArgDesc(1 To 4) As String
FuncName = "RoundToSum"
FuncDesc = "Rounding values preserving their rounded sum"
Category = mcMath_and_Trig
ArgDesc(1) = "Range or array which contains unrounded values"
ArgDesc(2) = "[Optional = 2] Number of digits to round to. For example: 0 rounds to integers, 2 rounds to the cent, -3 will use thousands"
ArgDesc(3) = "[Optional = True] True takes the summands as they are; False works on the summands' percentages to make all percentages add up to 100% exactly"
ArgDesc(4) = "[Optional = 1] Error type: 1= absolute error, 2 = relative error"
Application.MacroOptions _
  Macro:=FuncName, _
  Description:=FuncDesc, _
  Category:=Category, _
  ArgumentDescriptions:=ArgDesc
End Sub

Round2Sum:
=LAMBDA(vI;lD;bA;lE;
	LET(
		i;WENN(bA;vI;vI/SUMME(vI)%);
		r;RUNDEN(i;lD);
		_C;RUNDEN(SUMME(i);lD)-SUMME(r);
		_E;WAHL(lE;r-i;(r-i)*i);
		_R; UniqRank(_E;WENN(_C>0;1;0));
		_D;WENN(_R<=RUNDEN(ABS(_C*10^lD);0);VORZEICHEN(_C)*10^-lD;0);
		r+WENN(ZEILEN(r)=1;MTRANS(_D);_D)
	)
)

UniqRank:
=LAMBDA(Ref;[Order];
	LET(
		_ord;WENN(WURDEAUSGELASSEN(Order);-1;WENN(Order=0;-1;1));
		_r;INDEX(WENN(ZEILEN(Ref)=1;MTRANS(Ref);Ref);;1);
		_c;ZEILEN(_r);
		_i;SEQUENZ(ZEILEN(_r));
		INDEX(SORTIEREN(HSTAPELN2(_i;INDEX(SORTIEREN(HSTAPELN2(_r;_i);;_ord);;2));2;1);;1)
	)
 )

HSTAPELN2:
=LAMBDA(a;b;
	MATRIXERSTELLEN(
		ZEILEN(a);
		2;
		LAMBDA(r;c;
			WENN(c=1;INDEX(a;r);INDEX(b;r))
		)
	)
)