我正在使用一段VBA代码来截断Excel中的输入数字，但在特定情况下，它不起作用

Question

我使用这段 VBA 代码来截断 Excel 中的输入数字，但在某些情况下，它仍然对数字进行四舍五入而不是截断它们。当我尝试一些特定的数字时，它不起作用。我找到的例子是：1.11116、17.84116。

请注意，VBA 应用于操作员输入数据的空单元格。这就是为什么我不能简单地使用

trunc(A1,4)

或类似的命令。

这些是我遇到的唯一无法使用该代码的数字。两者都以 6 结尾，但是这个问题没有模式。

这是代码：

Option Explicit
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 = Interesect(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
   dValue=Int(iValue * Num)/Num
   If dValue<iValue Then
    iCell.Value=dValue
   End If
 End If
Next iCell
ProcExit:
 On Error Resume Next
  If Not Application.EnbaleEvents Then Application.EnableEvents = True
 On Error GoTo O
 Exit Sub
ClearError:
 Resume ProcExit
End Sub

有谁知道为什么会发生这种情况以及如何解决它？ 谢谢，

如果您有任何想法，请告诉我。

Answer 1

使用 WorksheetFunction.FLOOR(1.11116,0.0001) --> 1.1111

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Const TARGET_RANGE As String = "A1:A10"
  Const DECIMAL_PLACES As Double = 0.00001
  On Error GoTo ClearError
  Dim irg As Range
  Set irg = Interesect(Me.Range(TARGET_RANGE), Target)
  If irg Is Nothing Then Exit Sub
  Application.EnableEvents = False
  Dim iCell As Range, iValue as Variant
  For Each iCell In irg.Cells
    iValue = iCell.Value
    If VarType(iValue) = vbDouble Then
      iCell.Value = WorksheetFunction.FLOOR(iValue, DECIMAL_PLACES)
    End If
  Next iCell
ProcExit:
  On Error Resume Next
  If Not Application.EnbaleEvents Then Application.EnableEvents = True
  Exit Sub
ClearError:
  Resume ProcExit
End Sub

Answer 2

工作表更改：自动截断小数 2

改进

• 在我的之前的回答中，发布的代码来自于此，我没有意识到浮点数在更多小数位数时会出现问题。各种数学函数可以涵盖这一点。我选择了

  RoundUp

  ，这似乎是轻松满足要求的完美候选人。

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    Const TARGET_RANGE As String = "A1:A10"
    Const DECIMAL_PLACES As Long = 5
    Const DEBUG_PRINT_CHANGES As Boolean = True ' set to False when done testing

    On Error GoTo ClearError
    
    ' Attempt to reference (manually) changed cells of target range.
    Dim irg As Range: Set irg = Intersect(Me.Range(TARGET_RANGE), Target)
    If irg Is Nothing Then Exit Sub

    Application.EnableEvents = False

    Dim iCell As Range, Current, RoundedDown As Double, IsToBeChanged As Boolean

    For Each iCell In irg.Cells
        Current = iCell.Value
        ' Set flag if current value is DIFFERENT than rounded down value.
        ' NOT greater than because after rounding down,
        ' negative numbers may only become GREATER i.e. '-2.2 > -2.21'.
        If VarType(Current) = vbDouble Then ' is a number
            RoundedDown = Application.RoundDown(Current, DECIMAL_PLACES)
            If RoundedDown <> Current Then
                IsToBeChanged = True
            End If
        End If
        ' Print information to Immediate window (Ctrl+G).
        If DEBUG_PRINT_CHANGES Then
            Debug.Print IIf(IsToBeChanged, "Changed:     ", "Not changed: ") _
                & IIf(IsError(Current), iCell.Text, Current) _
                & IIf(IsToBeChanged, " to " & RoundedDown, "")
        End If
        ' If flag was set, write rounded down value to cell and reset flag.
        If IsToBeChanged Then
            iCell.Value = RoundedDown
            IsToBeChanged = False
        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

立即窗口中显示结果

Changed:     123.123455667 to 123.12345
Changed:     21.12312345 to 21.12312
Not changed: 1.11116
Changed:     -200.23423423 to -200.23423
Not changed: 100.36
Changed:     0.833599537037037 to 0.83359
Not changed: #DIV/0!
Not changed: #NAME?
Not changed: 45132
Not changed: Text

发生了什么事？

Sub Float()
    Debug.Print 100000 * 1.11116               ' Result: 111116
    Debug.Print Int(100000 * 1.11116)          ' Result: 111115 ' here!!!
    Debug.Print Int(100000 * 1.11116) / 100000 ' Result: 1.11115
End Sub

• 请注意，这不是一个错误。这是正常行为。

您帖子中的错别字

Interesect --> Intersect
Application.EnbaleEvents --> Application.EnableEvents
On Error GoTo O --> On Error GoTo 0
10^DECIMAL_PLACES --> 10 ^ DECIMAL_PLACES