“Every fool can know. The point is to understand.” [Albert Einstein]

Rounding Values Preserving Their Sum

Rounded values do not always sum up to their original total, as demonstrated in this article. How can you ensure that the sum of rounded percentages equals exactly 100%? Is it possible to guarantee that, for accounting purposes, the distribution of overhead costs precisely matches the original total? These challenges are well-known and have been studied extensively.

This article introduces a simple solution using Excel/VBA. The function presented here can round relative values (e.g., percentages) to ensure they sum to exactly 100%. It can also round absolute values (such as cost distributions) while preserving their original sum after rounding. A key parameter allows users to choose which type of error to minimize — absolute error or relative error — compared to the common half-up rounding method.

Note: This solution is limited to one-dimensional tables without subtotals. There is no general solution for higher-dimensional tables or tables with subtotals.

Program Code RoundToSum

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

Lambda Expression Round2Sum

Round2Sum:
=LAMBDA(vI,lD,bA,lE,
	LET(
		i,IF(bA,vI,vI/SUM(vI)%),
		r,ROUND(i,lD),
		_C,ROUND(SUM(i),lD)-SUM(r),
		_E,CHOOSE(lE,r-i,(r-i)*i),
		_R, UniqRank(_E,IF(_C>0,1,0)),
		_D,IF(_R<=ROUND(ABS(_C*10^lD),0),SGN(_C)*10^-lD,0),
		r+IF(ROWS(r)=1,TRANSPOSE(_D),_D)
	)
)

UniqRank:
=LAMBDA(Ref,[Order],
	LET(
		_ord,IF(ISOMITTED(Order),-1,IF(Order=0,-1,1)),
		_r,INDEX(IF(ROWS(Ref)=1,TRANSPOSE(Ref),Ref),,1),
		_c,ROWS(_r),
		_i,SEQUENCE(ROWS(_r)),
		INDEX(SORT(HSTACK2(_i,INDEX(SORT(HSTACK2(_r,_i),,_ord),,2)),2,1),,1)
	)
 )

HSTACK2:
=LAMBDA(a,b,
	MAKEARRAY(
		ROWS(a),
		2,
		LAMBDA(r,c,
			IF(c=1,INDEX(a,r),INDEX(b,r))
		)
	)
 )

Please read my Disclaimer.

Plumhoff_Rounding_Values_Preserving_Their_Sum.pdf [1.3 MB PDF file, open and use at your own risk]

roundtosum.xlsm [672 KB Excel file, open and use at your own risk]

Note: A comprehensive documentation of my Excel implementations can be found in Excel VBA A Collection.