Вы можете использовать эту функцию, которой вы передаете массив количеств и общей стоимости, и возвращается массив, содержащий подробную стоимость:
' Rounds a series of numbers so the sum of these matches the
' rounded sum of the unrounded values.
' Further, if a requested total is passed, the rounded values
' will be scaled, so the sum of these matches the rounded total.
' In cases where the sum of the rounded values doesn't match
' the rounded total, the rounded values will be adjusted where
' the applied error will be the relatively smallest.
'
' The series of values to round must be passed as an array.
' The data type can be any numeric data type, and values can have
' any value.
' Internally, the function uses Decimal to achieve the highest
' precision and Double when the values exceed the range of Decimal.
'
' The result is an array holding the rounded values, as well as
' (by reference) the rounded total.
'
' If non-numeric values are passed, an error is raised.
'
' Requires:
' RoundMid
'
' 2018-03-26. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function RoundSum( _
ByVal Values As Variant, _
Optional ByRef Total As Variant, _
Optional ByVal NumDigitsAfterDecimal As Long) _
As Variant
Dim SortedItems() As Long
Dim RoundedValues As Variant
Dim SortingValues As Variant
Dim Sum As Variant
Dim Value As Variant
Dim RoundedSum As Variant
Dim RoundedTotal As Variant
Dim PlusSum As Variant
Dim MinusSum As Variant
Dim RoundedPlusSum As Variant
Dim RoundedMinusSum As Variant
Dim ErrorNumber As Long
Dim Item As Long
Dim Sign As Variant
Dim Ratio As Variant
Dim Difference As Variant
Dim Delta As Variant
Dim SortValue As Variant
' Raise error if an array is not passed.
Item = UBound(Values)
' Ignore errors while summing the values.
On Error Resume Next
If Err.Number = 0 Then
' Try to sum the passed values as a Decimal.
Sum = CDec(0)
For Item = LBound(Values) To UBound(Values)
If IsNumeric(Values(Item)) Then
Sum = Sum + CDec(Values(Item))
If Err.Number <> 0 Then
' Values exceed range of Decimal.
' Exit loop and try using Double.
Exit For
End If
End If
Next
End If
If Err.Number <> 0 Then
' Try to sum the passed values as a Double.
Err.Clear
Sum = CDbl(0)
For Item = LBound(Values) To UBound(Values)
If IsNumeric(Values(Item)) Then
Sum = Sum + CDbl(Values(Item))
If Err.Number <> 0 Then
' Values exceed range of Double.
' Exit loop and raise error.
Exit For
End If
End If
Next
End If
' Collect the error number as "On Error Goto 0" will clear it.
ErrorNumber = Err.Number
On Error GoTo 0
If ErrorNumber <> 0 Then
' Extreme values. Give up.
Error.Raise ErrorNumber
End If
' Correct a missing or invalid parameter value for Total.
If Not IsNumeric(Total) Then
Total = 0
End If
If Total = 0 Then
RoundedTotal = 0
Else
' Round Total to an appropriate data type.
' Set data type of RoundedTotal to match Sum.
Select Case VarType(Sum)
Case vbSingle, vbDouble
Value = CDbl(Total)
Case Else
Value = CDec(Total)
End Select
RoundedTotal = RoundMid(Value, NumDigitsAfterDecimal)
End If
' Calculate scaling factor and sign.
If Sum = 0 Or RoundedTotal = 0 Then
' Cannot scale a value of zero.
Sign = 1
Ratio = 1
Else
Sign = Sgn(Sum) * Sgn(RoundedTotal)
' Ignore error and convert to Double if total exceeds the range of Decimal.
On Error Resume Next
Ratio = Abs(RoundedTotal / Sum)
If Err.Number <> 0 Then
RoundedTotal = CDbl(RoundedTotal)
Ratio = Abs(RoundedTotal / Sum)
End If
On Error GoTo 0
End If
' Create array to hold the rounded values.
RoundedValues = Values
' Scale and round the values and sum the rounded values.
' Variables will get the data type of RoundedValues.
' Ignore error and convert to Double if total exceeds the range of Decimal.
On Error Resume Next
For Item = LBound(Values) To UBound(Values)
RoundedValues(Item) = RoundMid(Values(Item) * Ratio, NumDigitsAfterDecimal)
If RoundedValues(Item) > 0 Then
PlusSum = PlusSum + Values(Item)
RoundedPlusSum = RoundedPlusSum + RoundedValues(Item)
If Err.Number <> 0 Then
RoundedPlusSum = CDbl(RoundedPlusSum) + CDbl(RoundedValues(Item))
End If
Else
MinusSum = MinusSum + Values(Item)
RoundedMinusSum = RoundedMinusSum + RoundedValues(Item)
If Err.Number <> 0 Then
RoundedMinusSum = CDbl(RoundedMinusSum) + CDbl(RoundedValues(Item))
End If
End If
Next
RoundedSum = RoundedPlusSum + RoundedMinusSum
If Err.Number <> 0 Then
RoundedPlusSum = CDbl(RoundedPlusSum)
RoundedMinusSum = CDbl(RoundedMinusSum)
RoundedSum = RoundedPlusSum + RoundedMinusSum
End If
On Error GoTo 0
If RoundedTotal = 0 Then
' No total is requested.
' Use as total the rounded sum of the passed unrounded values.
RoundedTotal = RoundMid(Sum, NumDigitsAfterDecimal)
End If
' Check if a correction of the rounded values is needed.
If (RoundedPlusSum + RoundedMinusSum = 0) And (RoundedTotal = 0) Then
' All items are rounded to zero. Nothing to do.
' Return zero.
ElseIf RoundedSum = RoundedTotal Then
' Match. Nothing more to do.
ElseIf RoundedSum = Sign * RoundedTotal Then
' Match, except that values shall be reversely signed.
' Will be done later before exit.
Else
' Correction is needed.
' Redim array to hold the sorting of the rounded values.
ReDim SortedItems(LBound(Values) To UBound(Values))
' Fill array with default sorting.
For Item = LBound(SortedItems) To UBound(SortedItems)
SortedItems(Item) = Item
Next
' Create array to hold the values to sort.
SortingValues = RoundedValues
' Fill the array after the relative rounding error and - for items with equal rounding error - the
' size of the value of items.
For Item = LBound(SortedItems) To UBound(SortedItems)
If Values(SortedItems(Item)) = 0 Then
' Zero value.
SortValue = 0
ElseIf RoundedPlusSum + RoundedMinusSum = 0 Then
' Values have been rounded to zero.
' Use original values.
SortValue = Values(SortedItems(Item))
ElseIf VarType(Values(SortedItems(Item))) = vbDouble Then
' Calculate relative rounding error.
' Value is exceeding Decimal. Use Double.
SortValue = (Values(SortedItems(Item)) * Ratio - CDbl(RoundedValues(SortedItems(Item)))) * (Values(SortedItems(Item)) / Sum)
Else
' Calculate relative rounding error using Decimal.
SortValue = (Values(SortedItems(Item)) * Ratio - RoundedValues(SortedItems(Item))) * (Values(SortedItems(Item)) / Sum)
End If
' Sort on the absolute value.
SortingValues(Item) = Abs(SortValue)
Next
' Sort the array after the relative rounding error and - for items with equal rounding error - the
' size of the value of items.
QuickSortIndex SortedItems, SortingValues
' Distribute a difference between the rounded sum and the requested total.
If RoundedPlusSum + RoundedMinusSum = 0 Then
' All rounded values are zero.
' Set Difference to the rounded total.
Difference = RoundedTotal
Else
Difference = Sgn(RoundedSum) * (Abs(RoundedTotal) - Abs(RoundedSum))
End If
' If Difference is positive, some values must be rounded up.
' If Difference is negative, some values must be rounded down.
' Calculate Delta, the value to increment/decrement by.
Delta = Sgn(Difference) * 10 ^ -NumDigitsAfterDecimal
' Loop the rounded values and increment/decrement by Delta until Difference is zero.
For Item = UBound(SortedItems) To LBound(SortedItems) Step -1
' If values should be incremented, ignore values rounded up.
' If values should be decremented, ignore values rounded down.
If Sgn(Difference) = Sgn(Values(SortedItems(Item)) * Ratio - RoundedValues(SortedItems(Item))) Then
' Adjust this item.
RoundedValues(SortedItems(Item)) = RoundedValues(SortedItems(Item)) + Delta
If Item > LBound(SortedItems) Then
' Check if the next item holds the exact reverse value.
If Values(SortedItems(Item)) = -Values(SortedItems(Item - 1)) Then
' Adjust the next item as well to avoid uneven incrementing.
Item = Item - 1
RoundedValues(SortedItems(Item)) = RoundedValues(SortedItems(Item)) - Delta
Difference = Difference + Delta
End If
End If
Difference = Difference - Delta
End If
If Difference = 0 Then
Exit For
End If
Next
End If
If Sign = -1 Then
' The values shall be reversely signed.
For Item = LBound(RoundedValues) To UBound(RoundedValues)
RoundedValues(Item) = -RoundedValues(Item)
Next
End If
' Return the rounded total.
Total = RoundedTotal
' Return the array holding the rounded values.
RoundSum = RoundedValues
End Function
Полный код на GitHub: VBA.Round
Для подробного ознакомления с кодом изучите мою статью:
Округлые элементы суммы, соответствующиевсего
Вход в систему не требуется.Просто найдите ссылку «Читать статью полностью» или аналогичную.