经典算法
Access VBA 四舍六入逢五奇进偶不进函数
2017-09-01 17:20:27

有网友提出过这样的问题“我想实现四舍六入逢五奇进偶不进”。遇到这种问题,我们都需要是自定义函数。

详细源码:Function Rvt(ByVal x As Double, ByVal n As Integer) As Double' 四舍六入逢五奇进偶不进的函数(Access VBA)' 作者:朱亦文    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 IfEnd 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 / FactorEnd Function