四舍六入逢五奇进偶不进的函数(Access VBA)

今天，有一网友提出一个问题“我想实现四舍六入逢五奇进偶不进”。

答曰：
Function Rvt(ByVal x As Double, ByVal n As Integer) As Double
' 四舍六入逢五奇进偶不进的函数(Access VBA)
' 作者：朱亦文
' 日期：2006.12.21

    Const IFIX = 15
    Dim sFmt As String
    Dim sRet As String, sTmp As String
    Dim intR As Integer, intRT As Integer

    If n < 0 Then n = 0
    sFmt = "0." & String(n + IFIX, "0")
   
    sTmp = Format(x, sFmt)
       
    If n = 0 Then
        intR = CInt(Left(Right(sTmp, IFIX + 2), 1))
        intRT = CInt(Left(Right(sTmp, n + IFIX), 1))
        sRet = Left(sTmp, Len(sTmp) - n - IFIX - 1)
    Else
        intR = CInt(Left(Right(sTmp, n + IFIX), 1))
        intRT = CInt(Left(Right(sTmp, n + IFIX - 1), 1))
        sRet = Left(sTmp, Len(sTmp) - n - IFIX + 1)
    End If
   
    If intRT = 5 Then
        If intR Mod 2 = 0 Then
            Rvt = CDbl(sRet)
        Else
            Rvt = Round(x, n)
        End If
    Else
        Rvt = Round(x, n)
    End If
End Function

立即窗口验证：
?Rvt(9992.45,1)
 9992.4
?Rvt(9992.55,1)
 9992.6
?Rvt(9992.54,1)
 9992.5
?Rvt(9992.46,1)
 9992.5
?Rvt(-9991.45015,1)
-9991.4
?Rvt(-9992.565015,0)
-9992
?Rvt(-9991.565015,0)
-9992 

另一个函数（银行家算法）：
Function BRound(ByVal X As Double, _
            Optional ByVal Factor As Double = 1) As Double
    '  For smaller numbers:
    '  BRound = CLng(X * Factor) / Factor
    Dim Temp As Double, FixTemp As Double
    Temp = X * Factor
    FixTemp = Fix(Temp + 0.5 * Sgn(X))
    ' Handle rounding of .5 in a special manner
    If Temp - Int(Temp) = 0.5 Then
        If FixTemp / 2 <> Int(FixTemp / 2) Then ' Is Temp odd
            ' Reduce Magnitude by 1 to make even
            FixTemp = FixTemp - Sgn(X)
        End If
    End If
    BRound = FixTemp / Factor
End Function