К сожалению, встроенные функции VBA, которые могут выполнять округление, либо отсутствуют, либо ограничены, неточны, либо содержат ошибки, и каждая из них касается только одного метода округления. Плюс в том, что они быстрые, и в некоторых ситуациях это может быть важно.
Однако, часто точность является обязательной, и с быстродействием компьютеров сегодня едва ли можно заметить немного более медленную обработку, даже не для обработки отдельных значений. Все функции по ссылкам ниже работают примерно за 1 мкс.
Полный набор функций - для всех распространенных методов округления, для всех типов данных VBA, для любого значения и без возврата неожиданных значений - можно найти здесь:
Округление значений вверх, вниз, на 4/5 или до значащих цифр (EE)
или здесь:
Округление значений вверх, вниз, на 4/5 или до значащих цифр (CodePlex)
Код только на GitHub:
VBA.Round
Они охватывают обычные методы округления:
Округление вниз с возможностью округления отрицательных значений до нуля
Округление с возможностью округления отрицательных значений от нуля
Округление на 4/5, либо от нуля до четного (округление банкира)
Округление до числа значащих цифр
Первые три функции принимают все числовые типы данных, а последние существуют в трех вариантах - для валюты, десятичной и двойной соответственно.
Все они принимают заданное количество десятичных знаков, включая отрицательное число, которое округляется до десятков, сотен и т. Д. Те, у которых Variant в качестве типа возврата будет возвращать Null для непонятного ввода
Также включен тестовый модуль для тестирования и валидации.
Пример здесь - для обычного округления 4/5. Пожалуйста, изучите встроенные комментарии для тонких деталей и как CDec используется, чтобы избежать битовых ошибок.
' Common constants.
'
Public Const Base10 As Double = 10
' Rounds Value by 4/5 with count of decimals as specified with parameter NumDigitsAfterDecimals.
'
' Rounds to integer if NumDigitsAfterDecimals is zero.
'
' Rounds correctly Value until max/min value limited by a Scaling of 10
' raised to the power of (the number of decimals).
'
' Uses CDec() for correcting bit errors of reals.
'
' Execution time is about 1µs.
'
Public Function RoundMid( _
ByVal Value As Variant, _
Optional ByVal NumDigitsAfterDecimals As Long, _
Optional ByVal MidwayRoundingToEven As Boolean) _
As Variant
Dim Scaling As Variant
Dim Half As Variant
Dim ScaledValue As Variant
Dim ReturnValue As Variant
' Only round if Value is numeric and ReturnValue can be different from zero.
If Not IsNumeric(Value) Then
' Nothing to do.
ReturnValue = Null
ElseIf Value = 0 Then
' Nothing to round.
' Return Value as is.
ReturnValue = Value
Else
Scaling = CDec(Base10 ^ NumDigitsAfterDecimals)
If Scaling = 0 Then
' A very large value for Digits has minimized scaling.
' Return Value as is.
ReturnValue = Value
ElseIf MidwayRoundingToEven Then
' Banker's rounding.
If Scaling = 1 Then
ReturnValue = Round(Value)
Else
' First try with conversion to Decimal to avoid bit errors for some reals like 32.675.
' Very large values for NumDigitsAfterDecimals can cause an out-of-range error
' when dividing.
On Error Resume Next
ScaledValue = Round(CDec(Value) * Scaling)
ReturnValue = ScaledValue / Scaling
If Err.Number <> 0 Then
' Decimal overflow.
' Round Value without conversion to Decimal.
ReturnValue = Round(Value * Scaling) / Scaling
End If
End If
Else
' Standard 4/5 rounding.
' Very large values for NumDigitsAfterDecimals can cause an out-of-range error
' when dividing.
On Error Resume Next
Half = CDec(0.5)
If Value > 0 Then
ScaledValue = Int(CDec(Value) * Scaling + Half)
Else
ScaledValue = -Int(-CDec(Value) * Scaling + Half)
End If
ReturnValue = ScaledValue / Scaling
If Err.Number <> 0 Then
' Decimal overflow.
' Round Value without conversion to Decimal.
Half = CDbl(0.5)
If Value > 0 Then
ScaledValue = Int(Value * Scaling + Half)
Else
ScaledValue = -Int(-Value * Scaling + Half)
End If
ReturnValue = ScaledValue / Scaling
End If
End If
If Err.Number <> 0 Then
' Rounding failed because values are near one of the boundaries of type Double.
' Return value as is.
ReturnValue = Value
End If
End If
RoundMid = ReturnValue
End Function