Option Explicit

Enum mc_Macro_Categories
    mcFinancial = 1
    mcDate_and_Time
    mcMath_and_Trig
    mcStatistical
    mcLookup_and_Reference
    mcDatabase
    mcText
    mcLogical
    mcInformation
    mcCommands
    mcCustomizing
    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, Optional bDontAmend As Boolean = False) 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.0 PB 26-Nov-2022 (C) (P) by Bernd Plumhoff
Dim 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)
For i = 1 To n
    d = IIf(bAbsSum, vA(i), vA(i) / dSumAbs * 100#): vC(i) = .Round(d, lDigits)
    If lErrorType = 1 Then 'Absolute error
        vD(i) = vC(i) - d
    ElseIf lErrorType = 2 Then 'Relative error
        vD(i) = (vC(i) - d) * d
    Else
        RoundToSum = CVErr(xlErrValue): Exit Function
    End If
Next i
If Not bDontAmend Then
    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 vC
        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(i) > lSgn * vD(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
End If
RoundToSum = vC
If TypeName(Application.Caller) = "Range" Then
    If Application.Caller.Rows.Count > Application.Caller.Columns.Count Then
        RoundToSum = .Transpose(vC) 'It's two-dimensional with 2nd dim const = 1
    End If
End If
Exit Function
Errhdl:
'Transpose variants to be able to address them with vA(i), not vA(i,1)
vA = .Transpose(vA): Resume Next
End With
End Function

Sub DescribeFunction_sbRoundToSum()
'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 5) 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"
ArgDesc(5) = "[Optional = False] True does not amend the rounded summands to match the rounded sum; False performs the calculation as described"
Application.MacroOptions _
    Macro:=FuncName, _
    Description:=FuncDesc, _
    Category:=Category, _
    ArgumentDescriptions:=ArgDesc
End Sub