截断Excel中输入的数字

Question

我使用 VBA 代码截断 Excel 中的输入数字。

在某些情况下，它会对数字进行四舍五入而不是截断。
示例：1.11116、17.84116。

代码被应用于操作员输入数据的空单元格。这就是为什么我无法使用

trunc(A1,4)

或类似命令。

这些是我遇到的代码不起作用的唯一数字。两者都以 6 结尾，但没有模式。

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