Significant Figures code suddenly stops working for numbers =>1000

[Barboza Babcock]

Hello All,

I'm losing it. What else is new? The code below has run flawlessly for quite some time. All results generated by our lab are reported to 3 sig figs. The other day the code below suddenly started leaving all values => 1000 unchanged.

If we select a cell => 1000 on the sheet and run ONLY the sig fig macro on the selected cell, the numbers change to sig figs. For example, 5637 is changed to 5640.

If we run CallSelectByValue() macro then SelectByValue() prior to SlectByValue running the SigFig() macro, numbers =>1000 are left unchanged. All the numbers in the specified ranges get selected, however, the numbers do not change when the SigFig() macro runs if the numbers selected are =>1000. Bizarre.

As above, if you just go to a sheet, and select any number and run the SigFig() macro only, the selected number is set to sig figs.

Sub CallSelectByValue()
   
     'Call the macro and pass all the required variables to it.
     'In the line below, change the Range, Minimum Value, and Maximum Value as needed
Select Case ActiveSheet.Name
   Case Is = "Vol Log"
      Set rngSearchFor = Range("B9:PZ69")
      rngSearchFor.Select
   Case Is = "HAA Log"
      Set rngSearchFor = Range("D4:I68")
      rngSearchFor.Select
End Select

Call SelectByValue(Range(Selection.Address), 0.00000001, 0.9999999999)
rngSearchFor.Select
Call SelectByValue(Range(Selection.Address), 1, 9.99999999)
rngSearchFor.Select
Call SelectByValue(Range(Selection.Address), 10, 99.99999999)
rngSearchFor.Select
Call SelectByValue(Range(Selection.Address), 100, 999.99999999)
rngSearchFor.Select
Call SelectByValue(Range(Selection.Address), 1000, 9999.99999999)
rngSearchFor.Select
Call SelectByValue(Range(Selection.Address), 10000, 99999.99999999)
rngSearchFor.Select
Call SelectByValue(Range(Selection.Address), 100000, 999999.99999999)
End Sub

Sub SelectByValue(Rng1 As Range, MinimunValue As Double, MaximumValue As Double)
   
    Dim MyRange As Range
    Dim Cell As Object
     'Check every cell in the range for matching criteria.
    For Each Cell In Rng1
        If Cell.Value >= MinimunValue And Cell.Value <= MaximumValue Then
            If MyRange Is Nothing Then
                Set MyRange = Range(Cell.Address)
            Else
                Set MyRange = Union(MyRange, Range(Cell.Address))
              Set MyRange = Union(MyRange, Range(Cell.Address))
            End If
       End If
    Next
     'Select the new range of only matching criteria
   
    If MyRange Is Nothing Then
       Exit Sub
    Else
       MyRange.Select
    End If
   
    Run ("SigFig")
End Sub

Sub SigFig()
'
' SigFig Macro

' Use function SigDig to put digits into sig figs.
If IsNumeric(ActiveCell) Then
   ActiveCell = SigDig(ActiveCell, 3)
      Select Case ActiveCell
         Case Is < 0.1 And ActiveSheet.Name <> "ICPDATA"
            Selection.NumberFormat = "0.0000"
         Case Is < 1
            Selection.NumberFormat = "0.000"
         Case Is < 10
            Selection.NumberFormat = "0.00"
         Case Is < 100
            Selection.NumberFormat = "0.0"
         Case Is < 1000
            Selection.NumberFormat = "0"
         Case Is < 10000
            Selection.NumberFormat = "00"
         Case Is < 100000
            Selection.NumberFormat = "000"
         Case Is < 1000000
            Selection.NumberFormat = "0000"
  End Select
End If

As always, any help is greatly appreciated.
Thanks!!

 

[StephenCrump]

The code below has run flawlessly for quite some time. All results generated by our lab are reported to 3 sig figs. The other day the code below suddenly started leaving all values => 1000 unchanged.

I doubt your code has run flawlessly in the past, as you have a fundamental problem here:

    '....
    MyRange.Select
    Run ("SigFig")
   
End Sub
Sub SigFig()

    If IsNumeric(ActiveCell) Then ActiveCell = SigDig(ActiveCell, 3)
    '....

MyRange potentially contains many discontiguous cells, and you want to round them all. However, ActiveCell always refers only to a single cell, so your code will round only one value.

It's inefficient and rarely necessary to write code based on .Select, .Selection, .ActiveSheet, .ActiveCell etc. Here's a more succinct way you could code this:

Sub Test()

    Dim rng As Range
    Dim Values As Variant
    Dim S As Long, N As Long, i As Long, j As Long
    
    Set rng = Worksheets("Vol Log").Range("B9:PZ69")
    rng.NumberFormat = "#,##0"
    S = 3
    
    Values = rng.Value2
    For i = 1 To UBound(Values)
        For j = 1 To UBound(Values, 2)
            If Values(i, j) = 0 Then
                N = 0
            Else
                N = S - Int(Application.Log(Abs(Values(i, j)))) - 1
                If N > 0 Then rng(i, j).NumberFormat = "#,##0." & String(N, "0")
            End If
            Values(i, j) = Application.Round(Values(i, j), N)
        Next j
    Next i
    
    rng.Value = Values
    
End Sub

 

[Barboza Babcock]

Wow. That sure is a lot slicker, more concise and quicker than what I was doing.

One problem. There are several empty cells in the range.
The empty cells cause a type mismatch error at this line:

N = IIf(Values(i, j) = 0, 0, S - Int(Application.Log(Abs(Values(i, j)))) - 1)

Unfortunately I am not a programmer, and my only ideas involve ugly brute force (fill in a bunch of zeroes, then clear the contents).

Do you have a suggestion for ignoring empty cells?

Before I forget - many thanks for your code and suggestions.

 

[StephenCrump]

You were quick! I edited that line out a couple of minutes after posting.

Try this:

Sub Test()

    Dim rng As Range
    Dim Values As Variant
    Dim S As Long, N As Long, i As Long, j As Long
    
    Set rng = Worksheets("Vol Log").Range("B9:PZ69")
    rng.NumberFormat = "#,##0"
    S = 3
    
    Values = rng.Value2
    For i = 1 To UBound(Values)
        For j = 1 To UBound(Values, 2)
            If Values(i, j) <> 0 Then
                N = S - Int(Application.Log(Abs(Values(i, j)))) - 1
                If N > 0 Then rng(i, j).NumberFormat = "#,##0." & String(N, "0")
                Values(i, j) = Application.Round(Values(i, j), N)
            End If
        Next j
    Next i
    
    rng.Value = Values
    
End Sub

 

[Barboza Babcock]

Perfect.

THANK YOU!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!