Private Function GetNumber(f As Double, iPos As Integer) As String
Dim k As Integer
Dim i As Double
Dim s As String
Dim s1 As String
Dim s2 As String
Dim k1 As Double, k2 As Double
s = CStr(f)
i = InStr(1, s, ".") '查找小数点的位置
'检查是否需要进行处理
s1 = Mid(s, i + iPos + 1, 1)
s2 = Mid(s, i + iPos, 1)
k = Val(s1)
k2 = Val(s2)
If Len(s) - i < iPos Then
MsgBox "小数位数不足，请人工检查"
End If
If Len(s) - i = iPos Then s1 = s
If Len(s) - i > iPos Then '最后一位<5：舍去，>5：进位，=5：奇进偶舍

If k < 5 Then '舍去
s1 = Left$(s, i + iPos)
ElseIf k > 5 Then '进位
s1 = Mid(s, i + iPos, 1)
k = Val(s1)
k = k + 1
s1 = Left$(s, i + iPos - 1) + Trim(Str(k))
ElseIf k = 5 Then '奇进偶舍
s1 = Mid(s, i + iPos, 1)
k = Val(s1)
k2 = Len(s) - i - iPos - 1
If k2 = 0 Then '偶舍
If k Mod 2 = 0 Then
s1 = Left$(s, i + iPos)
Else '奇进
k = k + 1
s1 = Left$(s, i + iPos - 1) + Trim$(Str(k))
End If
Else
k = k + 1
s1 = Left$(s, i + iPos - 1) + Trim$(Str(k))
End If
End If
End If

' s1 = Format(s1, "####0.000")
' Print s1
GetNumber = CStr(s1) '送回处理后的数据
End Function


基本能满足要求了，就是当小数位数太多的时候，不能舍去
比如1.05450000000000000000000000000152保留三位小数，应当是1.055，程序显示却是1.054