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

问：

我使用这段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

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

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

VBA Excel 公式舍入截断

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

1赞 VBasic2008 7/25/2023 #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

上一个：用于数据转换的 SSIS 高级编辑器

下一个：如何在不截断的情况下从另一个表中的长文本字段更新长文本字段

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

I am using a piece of VBA code to truncate the input numbers in Excel but in specific cases, it does NOT work

评论

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