I am a supporter of
St. Joseph's hospice.
 If you find this site useful or if it helped you, consider a small donation to
St. Joseph's, please.

Information on
St. Joseph's

JustGiving - Sponsor me now!

 

sbRoundToSum

"All some folks want is their fair share and yours." [Arnold H. Glasow]

You need to present percentages of some numbers but they need to sum up to 100% EXACTLY?

Example: You have 115, 222 and 333 but their percentages (rounded to 2 decimals) 17.16%, 33.13% and 49.70% add up to 99.99%, not 100%.

This is how it works - see two examples: one for absolute values, the other for percentages (relative values). This method minimizes the absolute error if you need to amend a value:

sbRoundToSum_Screen1

Please notice that this method is a derivation of the Hare-Niemeyer method. A practical implementation of this method you can see at this allocation of overhead costs.

Other, but similar methods are shown at D’Hondt Method and at sbExactRandHistogrm.

If you like to know more about the distribution of sums of rounded percentages, see Mosteller, Youtz and Zahn: "The Distributions of Sums of Rounded Percentages", Demography (1967), 4, p. 850 - 858, or Diaconis and Freedman: "On Rounding Percentages", Journal of the American Statistical Association, Vol. 74, No. 366. (Jun., 1979), pp. 359-364.

You can download a 50 KB Excel 2013 © sample file here but please notice my disclaimer.

Name

sbRoundToSum - Calculate rounded summands which exactly add up to the rounded sum of unrounded summands

Synopsis

sbRoundToSum(vInput, [lDigits], [bAbsolute], [bDontAmend])

Description

sbRoundToSum calculates rounded summands which exactly add up to the rounded sum of the unrounded summands.
It uses the largest remainder method which minimizes the absolute error to the original unrounded summands.
This function needs to be entered as an array formula into the cells for the rounded summands.

Example

If you need to distribute 1 EUR to three people, all of them should get 1/3 EUR but you need to amend this to whole cents:

sbRoundToSum_Example1

Options

vInput
      Range or array which contains unrounded summands

lDigits
     
Optional - standard value is 2 if not provided
      Number of digits to round to. For example: 0 rounds to integers, 2 rounds to the cent, -3 will use thousands

bAbsolute
      Optional - standard value is True if not provided
      True - takes the summands as they are
      False - works on the summands' percentages to make all percentages add up to 100% exactly

bDontAmend
      Optional - standard value is False if not provided
      True - do not amend the rounded summands to match the rounded sum. This parameter is mainly for ease of use or
                 presentation to see this function's impact
      False - perform amendments as described above

See Also

Think Cell’s TCRound ©
Allocation of Overheads
D’Hondt Method
sbExactRandHistogrm

Further Reading

Mosteller, Youtz and Zahn: "The Distributions of Sums of Rounded Percentages", Demography (1967), 4, p. 850 - 858
Diaconis and Freedman: "On Rounding Percentages", Journal of the American Statistical Association, Vol. 74, No. 366. (Jun., 1979), pp. 359-364

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 sbRoundToSum(vInput As Variant, _
    Optional lDigits As Long = 2, _
    Optional bAbsolute As Boolean = True, _
    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 absolute error to the original unrounded summands.
'This function needs to be entered as an array formula into the cells for the rounded summands.
'http://sulprobil.com/Get_it_done/IT/Excel_Fun/Excel_VBA/sbRoundToSum/sbroundtosum.html
'Reverse("moc.LiborPlus.www") V1.0 PB 31-Mar-2019
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(bAbsolute, vA(i), vA(i) / dSumAbs * 100#): vC(i) = .Round(d, lDigits): vD(i) = vC(i) - d
Next i
If Not bDontAmend Then
    dRoundedSum = .Round(IIf(bAbsolute, 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 d = m(i): m(i) = m(j): m(j) = d
            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
    End If
End If
sbRoundToSum = vC
On Error Resume Next
If TypeName(Application.Caller) = "Range" And _
    Application.Caller.Rows.Count > Application.Caller.Columns.Count Then
    sbRoundToSum = .Transpose(vC)
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 = "sbRoundToSum"
FuncDesc = "Calculate rounded summands which exactly add up to the rounded sum of unrounded summands"
Category = mcFinancial
ArgDesc(1) = "Range or array which contains unrounded summands"
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 = 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

Sulprobil   Get it done   Contact   Disclaimer   Impressum   Download