Impressum und Haftungsaus-
schluss lesen

sbRoundToSum
sbRoundToSum_Deutsch_01_Screen

Ein Anwendungsbeispiel für diese Funktion besteht in einer einfachen Gemeinkostenumlage.

Die benutzerdefinierte Excel© VBA Funktion sbRoundToSum (Die vorgestellten Programmbeispiele sind als Anregung und Lehrbeispiele zu verstehen. Für ordnungsgemäße Funktion, Fehler- oder Virenfreiheit wird keine Garantie übernommen. Siehe auch Haftungsausschluss):

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/Worksheet_Functions/Largest_Remainder/largest_remainder.html
'Reverse("moc.LiborPlus.www") V1.0 PB 29-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 BeschreibeFunktion_sbRoundToSum()
'Diese Routine nur einmal ausführen. Dann kann man die Beschreibung im Excel Funktionsmenu sehen
Dim FuncName As String, FuncDesc As String, Category As String, ArgDesc(1 To 4) As String
FuncName = "sbRoundToSum"
FuncDesc = "sbRoundToSum berechnet die gerundeten Summanden damit genau die gerundete Summe herauskommt"
Category = mcFinancial
ArgDesc(1) = "Bereich oder Array welches die ungerundeten Summanden enthält"
ArgDesc(2) = "[Optional = 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"
ArgDesc(3) = "[Optional = WAHR] WAHR nimmt die Summanden als absolute Werte so wie sie sind; FALSCH verwendet die Prozentzahlen der Summanden um genau auf 100% zu kommen"
ArgDesc(4) = "[Optional = FALSCH] WAHR passt die gerundeten Summanden nicht an um die gerundete Summe zu erreichen. Dieser Parameter dient zur einfachen Veranschaulichung der Funktion; FALSCH führt die Funktion wie beschrieben aus"
Application.MacroOptions _
    Macro:=FuncName, _
    Description:=FuncDesc, _
    Category:=Category, _
    ArgumentDescriptions:=ArgDesc
End Sub

[Home] [Über uns] [Unser Angebot] [Infopool] [Kontakt] [Impressum] [AGB]