Sub Закрасить_по_дробной_части()
    
    Dim lngChislo As Long
    Dim arr(), var, lr As Long, i As Long, j As Long
    
    Application.ScreenUpdating = False
    
    lngChislo = Range("J1").Value
    Columns("A:F").Interior.ColorIndex = xlColorIndexNone
    lr = Columns("A:F").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    arr() = Range("A1:F" & lr).Value
    For i = 1 To UBound(arr)
        For j = 1 To UBound(arr, 2)
            
            If IsError(arr(i, j)) Then
                GoTo metka
            End If
            If arr(i, j) = "" Then
                GoTo metka
            End If
            If IsNumeric(arr(i, j)) = False Then
                GoTo metka
            End If
            
            var = Split(arr(i, j), ",")
            If UBound(var) > 0 Then
                If Len(var(1)) = lngChislo Then
                    Cells(i, j).Interior.Color = vbRed
                End If
            End If
metka:
        Next j
    Next i
    
    Application.ScreenUpdating = True

End Sub