四舍六入逢五奇进偶不进的函数,但是不能实现小数点前用零站位，如果是9.6能变成9.60用0补齐，.68变0.68，.07变为0.07保留两位小数.可以得用FORMAT但我不知道如何修改,基本运算都行,就是差零占位,希望大家都帮忙.
 Private Sub Command1_Click()

Print Rvt(0.075, 2)
 End Sub


Function Rvt(ByVal x As Double, ByVal n As Integer) As Double
'四舍六入逢五奇进偶不进的函数

    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), 2))
        sRet = Left(sTmp, Len(sTmp) - n - IFIX + 2)
    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

如果你要做到 小数点 后补零的话, 函数返回值,就必须不能为 Double ,而必须为 string
Double  小数点后面的占位零会被自动忽略的. 所以是得不到你所需要的结果的.

函数具体过程,我没看

我重写的代码,你看一下,好像除下变量名相同外,全改掉了.


Function Rvt(ByVal x As Double, ByVal n As Integer) As String
'四舍六入逢五奇进偶不进的函数
   
    Dim sFmt As String
    Dim sRet1 As String, sRet2 As String
    Dim sTmp As String
    Dim intR As Integer

    If n < 0 Then n = 0         '位数必须是小数位数,不得小于 0
    sTmp = Str(x)               '转为 字符串   
    intR = InStr(1, sTmp, ".")      '小数点位置
    intR = intR + n                 '具体保存的那一位   
    sFmt = "0." & String(n, "0")    '生成掩模
        
'Format 包含 四舍五入功能,所以很多不需要处理.
'只需要处理 ,逢五奇进偶不进的情况,并且直接处理好数据来.
    If intR < Len(sTmp) Then       '保留的数据小于原始数据长度,大于长度的不需要处理
        sRet1 = Mid(sTmp, intR, 1)       '最后一后
        sRet2 = Mid(sTmp, intR + 1, 1)     '需要判断进位的        
        If sRet2 = "5" Then             '后面那位 等于5,不等于5的,不需要处理
            If Val(sRet1) Mod 2 = 0 Then         '偶数
                x = Val(Left(sTmp, intR))         '取掉后面的数,因为 format 会造成进位
            End If
        End If
    End If   
    Rvt = Format(x, sFmt)       '生成结果,
End Function

[ 本帖最后由 风吹过b 于 2010-11-3 09:32 编辑 ]

非常感谢版主的大力支持，但是此程序不满足如下的第两点，请帮助解决，真心的说声谢谢。

四舍六入的算法：要求取的有效数字的末一位的后一位数字小于等于4则舍，大于等于6则入，但对于等于5时可分成两种情况考虑：

（1）5后面的数字均为0时，应看“5”的前一位：若前一位数字此时为奇数，就应向前进一位；若前一位数字此时为偶数，则应将尾数舍去，数字“0”在此时应被视为偶数。

（2）5后面还有任何不是0的数字时，无论前一位在此时为奇数还是偶数，也无论“5”后面不为0的数字在哪一位上，都应向前进一位。

''''''''''''''''''''''此结果应该是0.07


Private Sub Command1_Click()

Dim x1 As Double
Dim y1 As String
x1 = 0.0651
y1 = Rvt(x1, 2)
Print y1


   
End Sub
Function Rvt(ByVal x As Double, ByVal n As Integer) As String
'四舍六入逢五奇进偶不进的函数
   
    Dim sFmt As String
    Dim sRet1 As String, sRet2 As String
    Dim sTmp As String
    Dim intR As Integer

    If n < 0 Then n = 0         '位数必须是小数位数,不得小于 0
    sTmp = Str(x)               '转为 字符串
    intR = InStr(1, sTmp, ".")      '小数点位置
    intR = intR + n                 '具体保存的那一位
    sFmt = "0." & String(n, "0")    '生成掩模
        
'Format 包含 四舍五入功能,所以很多不需要处理.
'只需要处理 ,逢五奇进偶不进的情况,并且直接处理好数据来.
    If intR < Len(sTmp) Then       '保留的数据小于原始数据长度,大于长度的不需要处理
        sRet1 = Mid(sTmp, intR, 1)       '最后一后
        sRet2 = Mid(sTmp, intR + 1, 1)     '需要判断进位的
        If sRet2 = "5" Then             '后面那位 等于5,不等于5的,不需要处理
            If Val(sRet1) Mod 2 = 0 Then         '偶数
                x = Val(Left(sTmp, intR))         '取掉后面的数,因为 format 会造成进位
            End If
        End If
    End If
    Rvt = Format(x, sFmt)       '生成结果,
End Function

还有一个问题如果我调用此函数，然后取值进行运算时，结果为 .2 没有零占位,如何解决,或是我写的代码需要如何修改,谢谢,我相信你能帮我.
Private Sub Command1_Click()

Dim x1 As Double
Dim y1, y2, y3 As String
x1 = 0.1
y1 = Rvt(x1, 2)
y2 = Rvt(x1, 2)
y3 = Val(y1) + Val(y2)

Print y3
 
End Sub

    If intR < Len(sTmp) Then       '保留的数据小于原始数据长度,大于长度的不需要处理

改为
    If intR = Len(sTmp) - 1 Then     '仅处理 保留长度为 原数据长度+1 的数据
就可以只处理 5后面全为零的情况.


Print y3
这句一定造成 无零的情况.
你必须使用 Format 函数转为字符串而 进行补零

多谢风吹过b版主

程序问题已解决，下面没有运用FORMAT直接又走了一遍函数，第两个问题已解决，成功补零。
Private Sub Command1_Click()

Dim x1 As Double
Dim y1, y2, y3, y4 As String
x1 = 0.1

y1 = Rvt(x1, 2)
y2 = Rvt(x1, 2)
y3 = Val(y1) + Val(y2)
y4 = Rvt(y3, 2)
Print y4

你这种解决方法测试过了？

试了几组数，还需要大量数据，才能定论。