Excel VBA输入数字截断功能异常问题求助

问题根源 #

1. 拼写错误：原代码存在多处拼写错误，导致逻辑执行异常：
   • Interesect → 正确为Intersect
   • Application.EnbaleEvents → 正确为Application.EnableEvents
   • On Error GoTo O → 正确为On Error GoTo 0
2. 浮点数精度误差：VBA的Double类型采用二进制浮点存储，部分十进制小数（如1.11116、17.84116）无法被精确表示，导致iValue * Num的计算结果出现微小偏差，最终Int函数的处理结果不符合截断预期。

修正后的代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    Const TARGET_RANGE As String = "A1:A10"
    Const DECIMAL_PLACES As Long = 5
    On Error GoTo ClearError
    
    Dim irg As Range: Set irg = Intersect(Me.Range(TARGET_RANGE), Target)
    If irg Is Nothing Then Exit Sub
    
    Dim Num As Long: Num = 10 ^ DECIMAL_PLACES
    Application.EnableEvents = False
    
    Dim iCell As Range, iValue, dValue As Double
    For Each iCell In irg.Cells
        iValue = iCell.Value
        If VarType(iValue) = vbDouble Then
            ' 使用CDec转换为十进制精确类型，避免浮点精度误差
            dValue = Int(CDec(iValue) * Num) / Num
            If dValue < iValue Then
                iCell.Value = dValue
            End If
        End If
    Next iCell

ProcExit:
    On Error Resume Next
    If Not Application.EnableEvents Then Application.EnableEvents = True
    On Error GoTo 0
    Exit Sub

ClearError:
    Resume ProcExit
End Sub

关键改进说明 #

• 修复拼写错误：修正了影响代码执行的拼写问题，确保逻辑正常触发。
• 解决精度问题：通过CDec(iValue)将输入的Double值转换为Decimal类型（十进制精确浮点），避免二进制浮点存储带来的精度偏差，确保iValue * Num的计算结果完全符合十进制逻辑，Int函数处理后即可得到准确的截断值。
• 保留原有逻辑：维持了仅对目标单元格、仅当截断后值小于原输入值时才更新的逻辑，避免不必要的单元格修改。

内容的提问来源于stack exchange，提问作者Milad