“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:
Werte | Prozent | |
---|---|---|
11 | 1,80 | |
45 | 7,36 | |
555 | 90,83 | |
Summe | 611 | 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.
Minimiere absoluten Fehler | Minimiere gewichteten absoluten Fehler | |||
---|---|---|---|---|
Werte | Round to 1,000 | RoundToSum (…,-3,…,1) | RoundToSum (…,-3,…,2) | |
4,523 | 5,000 | 5,000 | 5,000 | |
456 | 0 | 0 | 0 | |
-78,845 | -79,000 | -79,000 | -79,000 | |
-14,491 | -14,000 | -15,000 | -14,000 | |
65,789 | 66,000 | 66,000 | 66,000 | |
129,512 | 130,000 | 129,000 | 129,000 | |
15,562 | 16,000 | 16,000 | 16,000 | |
548,555 | 549,000 | 549,000 | 548,000 | |
1,590 | 2,000 | 2,000 | 2,000 | |
-897 | -1,000 | -1,000 | -1,000 | |
6,968 | 7,000 | 7,000 | 7,000 | |
2,987 | 3,000 | 3,000 | 3,000 | |
Summe | 681,709 | 684,000 | 682,000 | 682,000 |
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]