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

Abstract

Gerundete Werte ergeben zusammen nicht immer ihre gerundete Summe, wie man hier sehen kann. Wie stelle ich sicher, dass meine Aufstellung von gerundeten Prozentzahlen genau 100% ergibt? Kann ich für meine Buchhaltung sicherstellen, dass meine Gemeinkostenverrechnung genau die originale Kostensumme verteilt? Diese Fragen sind seit langem bekannt und wurden oft analysiert. In diesem Artikel wird eine einfach nutzbare Lösung mit Excel / VBA vorgestellt. Sie kann relative Werte (Prozentzahlen) auf 100% runden oder absolute Werte (z. B. Kostenrechnungsergebnisse) runden, ohne deren gerundete Summe zu verändern. Dabei kann je nach Parameter im Vergleich zur üblichen kaufmännischen Rundung der absolute Fehler oder der relative Fehler minimal gehalten werden.

Beispiel für Prozentzahlen

Die Werte 11, 45 und 555 mit der Summe 611 zeigen als Prozentsumme auf 2 Nachkommastellen gerundet nicht 100,00, sondern 99,99. Die fett markierten Werte innerhalb der Tabelle zeigen die von der Funktion RoundToSum veränderten gerundeten Werte:

Die hier vorgestellte Excel / VBA Funktion würde jedoch mit dem Aufruf RoundToSum({11;45;555};2;FALSCH) die Ergebniswerte {1,80;7,37;90,83} liefern. Der Prozentwert 7,364975 wurde hier zur “falschen” Seite hin gerundet, um die Prozentsumme 100,00 zu erhalten und dabei den absoluten Fehler gegenüber der kaufmännischen Rundung zu minimieren. Mit dem Aufruf RoundToSum({11;45;555};2;FALSCH;2) hätten wir die Ergebniswerte {1,80;7,36;90,84} erhalten, weil hier der Fehlertyp Parameter 2 den relativen Fehler minimal gehalten hätte.

Beispiel für absolute Zahlen

Die Summe der kaufmännisch gerundeten Werte in Spalte 2 weicht um +2.000 von der gerundeten Summe ab. Die fett markierten Werte innerhalb der Tabelle zeigen die von der Funktion RoundToSum veränderten gerundeten Werte.

Beispiel für eine komplexere Anwendung: Gemeinkostenumlage

Siehe Gemeinkostenumlage.

RoundToSum im Vergleich mit anderen “einfachen” Methoden

Siehe RoundToSum (VBA) im Vergleich.

RoundToSum im Vergleich zu sbDHondt

RoundToSum implementiert das Hare-Niemeyer Verfahren. Dies ist in mancher Hinsicht hinsichtlich der fairen Mandatsverteilung dem D’Hondt Verfahren überlegen. Siehe sbDHondt.

Beispiel für den Umgang mit dem Mandatszuwachsparadoxon: Faire Mitarbeiterauswahl nach Teamgröße

Siehe Faire Mitarbeiterauswahl für Sonderaufgaben.

Ein weiteres Anwendungsbeispiel für ein exaktes Verhältnis von Zufallszahlen

Siehe sbExactRandHistoGrm (VBA).

Die Excel / VBA Funktion RoundToSum

Name

RoundToSum – Summanden runden ohne Veränderung der gerundeten Summe

Synopsis

RoundToSum(vInput; [lDigits]; [bAbsSum]; [lErrorType]; [bDontAmend])

Beschreibung

RoundToSum rundet die Summanden, ohne deren gerundete Summe zu verändern. Es verwendet die Largest Remainder Methode (auch Hare-Niemeyer Verfahren genannt), um den Fehler gegenüber der üblichen kaufmännischen Rundung zu minimieren. Falls dieser Fehler für mehrere Summanden identisch ist, wird der erste oder die ersten Summanden angepasst.

Anmerkung: Die hier vorgestellte Lösung ist auf eindimensionale Tabellen ohne Teilsummen beschränkt. Für zweidimensionale Tabellen oder Tabellen mit Teilsummen existiert keine allgemeingültige Lösung.

Parameter

vInput – Bereich oder Array, welches die nicht gerundeten Summanden (Eingabewerte) enthält.

lDigits – Optional, der Standardwert ist 2. Anzahl der Stellen, auf die gerundet werden soll. Zum Beispiel: 0 rundet auf ganze Zahlen, 2 rundet auf den Cent, -3 rundet auf Tausender.

bAbsSum – Optional, der Standardwert ist WAHR. WAHR nimmt die Summanden (Eingabewerte) als unveränderte absolute Werte. FALSCH verwendet die Prozentzahlen der Summanden, um genau auf die Summe 100% zu kommen.

lErrorType – Optional, der Standardwert ist 1. Fehlertyp, der minimal gehalten werden soll: 1 – absoluter Fehler, 2 – relativer Fehler).

bDontAmend – Optional, der Standardwert ist FALSCH. WAHR lässt die Eingabewerte unverändert. FALSCH führt die Funktion wie beschrieben aus. Dieser Parameter dient zur einfachen Veranschaulichung der Funktion.

Literatur

Diaconis, P., & Freedman, D. (13. Juli 2007). (Externer Link!) On Rounding Percentages.

Sande, G. (7. August 2005). Guaranteed Controlled Rounding for Many Totals in Multi-way and Hierarchical Tables. Von (externer Link!) https://nces.ed.gov/FCSM/pdf/2005FCSM_Sande_IXA.pdf abgerufen

N. Herrmann, Mathematik ist überall, Oldenbourg Verlag München Wien, ISBN 3-486-57583-X (Kapitel 12, Das Wahl-Problem).

Appendix – Programmcode RoundToSum

Bitte den Haftungsausschluss im Impressum beachten.

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

Download

Bitte den Haftungsausschluss im Impressum beachten.

roundtosum.xlsm [63 KB Excel Datei, ohne jegliche Gewährleistung]