RoundToSum (VBA) ·

“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).

Literatur

Ein vergnügliches Büchlein ist:

N. Herrmann, Mathematik ist überall, Oldenbourg Verlag München Wien, ISBN 3-486-57583-X

Siehe Kapitel 12, Das Wahl-Problem.

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

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 '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

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

Bitte den Haftungsausschluss im Impressum beachten.

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