Error message when cell value is over 4 decimals-CodePudding

Problem: VBA written to give an error msgbox and red font when any value in column C or D has more than 4 decimals. Looping through the values, it seems that completely random values are getting the red font.

Code (the 'date' if's are working, but still included them) NB2: Msgbox is written after this piece of code:

With ThisWorkbook.Worksheets("Blad1")
   Do While .Range("B" & x).Value <> "" 'checken tot er een lege rij tussen zit

      If .Range("B" & x).Value   1 <= Date Then .Range("B" & x).Font.Color = vbRed 'maak de datum rood als deze in het verleden ligt
      If .Range("B" & x).Value   1 <= Date Then .Range("E999").Value = "TRUE" 'cel vullen met WAAR wanneer datum in het verleden ligt
      If .Range("C" & x).Value > Round((.Range("C" & x).Value), 4) Then .Range("C" & x).Font.Color = vbRed
      If .Range("D" & x).Value > Round((.Range("C" & x).Value), 4) Then .Range("D" & x).Font.Color = vbRed


      x = x   1
   Loop
End With

CodePudding user response：

You need to check the value if it's even a valid date with If IsDate(.Range("B" & x).Value) Then... for example, and if it is do the 4 IFs.

Also you should do the checks for C and D cells if they are numeric with IsNumeric(...) and also if they are not empty, because IsNumeric for empty cells gives true.

One more thing @FaneDuru pointed out correctly about rounding, you should do the following instead if Len(.Range("D" & x).Value) - Len(Fix(.Range("D" & x).Value)) > 5 then... Keep in mind Fix fails if value is not numeric

CodePudding user response：

You cannot use Round here - it is the length of the mantissa to measure:

' Returns the mantissa of a decimal number as
' a string to preserve leading zeroes.
'
' Examples:
'   Mantissa(1234.56789)    -> "56789"
'   Mantissa(-1234.56789)   -> "56789"
'   Mantissa(1234.056789)   -> "056789"
'   Mantissa(-1234.056789)  -> "056789"
'   Mantissa(123456789)     -> ""
'
' 2017-10-15. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function Mantissa( _
    ByVal Number As Double) _
    As String

    Dim Result      As String
    Dim Fraction    As Variant
    
    Fraction = CDec(Number) - CDec(Fix(Number))
    
    If Fraction <> 0 Then
        Result = Mid(Str(Abs(Fraction)), 3)
    End If

    Mantissa = Result
    
End Function

Then:

    If DateDiff("d", .Range("B" & x).Value, Date) >= 1 Then .Range("B" & x).Font.Color = vbRed 'maak de datum rood als deze in het verleden ligt
    If DateDiff("d", .Range("B" & x).Value, Date) >= 1 Then .Range("E999").Value = "TRUE" 'cel vullen met WAAR wanneer datum in het verleden ligt
    If Len(Mantissa(.Range("C" & x).Value)) > 4 Then .Range("C" & x).Font.Color = vbRed
    If Len(Mantissa(.Range("D" & x).Value)) > 4 Then .Range("D" & x).Font.Color = vbRed

CodePudding user response：

You receive such "random values" because of a wrong checking method...

Round does what the word suggests: It rounds the number. Less than 5 it rounds down and bigger or equal to 5 it rounds up. You need a function to Truncate the decimals...

Let us take:

Sub TestTruncateDecimals()
  Dim x As Double
  x = 1.12345
  Debug.Print x, Round(x, 4) '1.12345    1.1234 - OK
  x = 1.45678
  Debug.Print x, Round(x, 4) '1.45678    1.4568 - ? 1.4568 is bigger than 1.45678...
  
  Debug.Print x, truncDecimals(x, 4) '1.45678    1.4567 !!!
End Sub

Function truncDecimals(x As Double, decNo As Long) As Double
    Dim strX As String: strX = CStr(x)
    Dim sep As String: sep = Application.International(xlDecimalSeparator)
   
    If InStr(1, strX, sep) Then
        truncDecimals = Split(strX, sep)(0) & sep & left(Split(strX, sep)(1), decNo)
    Else
        truncDecimals = x
    End If
End Function

So, please copy the above function and use:

  If .Range("D" & x).Value > truncDecimals(.Range("C" & x).Value, 4) Then