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

Abstract

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 gewichtete absolute 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 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 gewichteten absoluten 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 existieren keine allgemeingültigen Lösungen.

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 – gewichtete Differenz (gewichteter absoluter 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). On Rounding Percentages. Von (externer Link!) http://statweb.stanford.edu/~cgates/PERSI/papers/freedman79.pdf abgerufen

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

Appendix – Programmcode RoundToSum

Bitte den Haftungsausschluss im Impressum beachten.

Option Explicit

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 'Weighted difference = Weighted absolute 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
    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

Bitte den Haftungsausschluss im Impressum beachten.

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