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

Question

I use this piece VBA code to truncate the input numbers in Excel but in some cases it still round the number rather than truncating them. When I try some specific numbers, it does NOT work. The examples I found are: 1.11116, 17.84116.

Please note that, the VBA is being applied to empty cells where an operator would enter data. That's why I can't simply use trunc(A1,4) or similar commands.

These are the only numbers I came across that the code does not work on. Both end with a 6, but there is no pattern to the issue.

This is the code:

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

Does anyone have any ideas why this is happening and how to fix it? Thanks,

Please let me know if you have any ideas.

"VBA has some exceptional conditions" -what do you mean by this? — Tim Williams, Jul 24 '23 at 18:30

rotabor · Accepted Answer · 2023-07-24T19:03:59.790

Use 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

score 1 · Answer 2 · answered Jul 25 '23 at 00:09

A Worksheet Change: Automatically Truncate Decimals 2

The Improvement

In my previous answer, where the posted code is taken from, I failed to realize that there will be trouble with floating point numbers at a greater number of decimals. Various math functions could cover this. I've opted for RoundUp which seems the perfect candidate to easily handle the requirement.

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

Results in the Immediate window

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

What Was Happening?

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

Note that this is not a bug. This is normal behavior.

Typos in Your Post

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

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

2 Answers2

A Worksheet Change: Automatically Truncate Decimals 2

Linked