Post by Bernd PNachtrag: Ein allgemeiner Ansatz sowohl für absolute als auch relative
(Prozent-) Zahlen:http://sulprobil.com/html/largest_remainder.html
Der Ansatz ist sehr gut, vor allen Dingen die Idee mit dem RankOfError
bei den Formeln!
Zur Funktion der Formeln kann ich nicht so viel sagen, die VBA-Routine
funktioniert jedoch nicht wenn die Summe aller Zahlen 0 ist.
Außerdem kann man sie nicht aus VBA heraus mit "V = LRM("A", -3, Range
("A1:A12"))" aufrufen, gibt einen RTE 424, weil Application.Caller
"Fehler 2023" ist.
Rufe ich sie mit einem Array(1 to 12) auf gibt es einen RTE 9 während
der Verarbeitung.
Aber der RankOfError hat mich auf eine Idee gebracht und die löst
viele Probleme. Nun habe ich eine Routine die alle (?) Fälle berechnen
kann und mit der man auch gerne mal 200% geben kann.
Aber rechnet sie tatsächlich immer richtig?
Andreas.
Function RundenZuSumme(Bereich As Variant, Stellen As Integer, _
Optional Soll, Optional Prozentual) As Variant
'Rundet alle Werte in Bereich auf Anzahl Stellen, _
modifiziert die Einzelwerte (prozentual) damit diese als _
Summe Soll ergeben, gibt alle Werte als Matrix zurück
Dim Result(), X As Long, Y As Long
Dim RankOfError(), i As Long, j As Long, k As Long
Dim Steps As Long, Diff, Rest, Summe, Temp
'Wenn kein Soll, dann gerundete Summe annehmen
If IsMissing(Soll) Then
With WorksheetFunction
Soll = .Round(.Sum(Bereich), Stellen)
End With
End If
Rest = Soll
'Prozentuale Verschiebung
If IsMissing(Prozentual) Then
Prozentual = False
Else
Prozentual = CBool(Prozentual)
End If
If Prozentual Then
Summe = WorksheetFunction.Sum(Bereich)
If Summe = 0 Or Soll = 0 Then Diff = 10 ^ -(Stellen - 1) _
Else Diff = 0
Diff = (Soll + Diff) / (Summe + Diff)
End If
If TypeOf Bereich Is Range Then
'Werte einlesen
With WorksheetFunction
Result = .Transpose(.Transpose(Bereich))
End With
ElseIf IsArray(Bereich) Then
'Sicherstellen das wir ein 2D-Array haben
Result = WorksheetFunction.Transpose(Bereich)
Else
'Damit kann ich nix anfangen
RundenZuSumme = Bereich
Exit Function
End If
'Korrekturwerte initialisieren
ReDim RankOfError(1 To 3, 1 To (UBound(Result) - LBound( _
Result) + 1) * (UBound(Result, 2) - LBound(Result, 2) + 1))
'Werte runden
For Y = LBound(Result) To UBound(Result)
For X = LBound(Result, 2) To UBound(Result, 2)
'Wert runden
If Prozentual Then
Temp = WorksheetFunction.Round(Result(Y, X) * Diff, _
Stellen)
Else
Temp = WorksheetFunction.Round(Result(Y, X), Stellen)
End If
i = i + 1
'Abweichung berechnen
RankOfError(1, i) = Abs(Result(Y, X) - Temp)
'Position speichern
RankOfError(2, i) = Y
RankOfError(3, i) = X
'Gerundeten Wert speichern
Result(Y, X) = Temp
'Vom Soll abziehen
Rest = Rest - Temp
Next
Next
'RankOfError sortieren
For i = LBound(RankOfError, 2) To UBound(RankOfError, 2) - 1
For j = i + 1 To UBound(RankOfError, 2)
If RankOfError(1, i) < RankOfError(1, j) Then
For k = LBound(RankOfError) To UBound(RankOfError)
Temp = RankOfError(k, i)
RankOfError(k, i) = RankOfError(k, j)
RankOfError(k, j) = Temp
Next
End If
Next
Next
'Anzahl Schritte
Steps = (Abs(Rest) / (10 ^ -Stellen))
'Speedup für große Abweichungen
If Steps > UBound(RankOfError, 2) Then
'Korrekturwert pro Schritt
Diff = (10 ^ -Stellen) * Sgn(Rest) * (Steps \ UBound( _
RankOfError, 2))
'Einmal alle Werte
For i = LBound(RankOfError, 2) To UBound(RankOfError, 2)
Result(RankOfError(2, i), RankOfError(3, i)) = Result( _
RankOfError(2, i), RankOfError(3, i)) + Diff
Next
'Restliche Schritte berechnen
Steps = Steps - (Steps \ UBound(RankOfError, 2)) * UBound( _
RankOfError, 2)
End If
'Korrekturwert pro Schritt
Diff = (10 ^ -Stellen) * Sgn(Rest)
'Die Ausgleichwerte korrigieren
j = LBound(RankOfError, 2) - 1
For i = 1 To Steps
j = j + 1
Result(RankOfError(2, j), RankOfError(3, j)) = Result( _
RankOfError(2, j), RankOfError(3, j)) + Diff
Next
If TypeOf Bereich Is Range Then
'Werte zurückgeben
RundenZuSumme = Result
Else
'Array zurückgeben
RundenZuSumme = WorksheetFunction.Transpose(Result)
End If
End Function