Significant Figures code suddenly stops working for numbers =>1000

Barboza Babcock

New Member
Joined
Jul 3, 2020
Messages
13
Office Version
  1. 365
Platform
  1. Windows
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.


VBA Code:
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!!
 

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.
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:

Rich (BB code):
    '....
    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:

VBA Code:
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
 
Last edited:
Upvote 0
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:

VBA Code:
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.
 
Upvote 0
You were quick! I edited that line out a couple of minutes after posting.

Try this:

VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,534
Messages
6,114,186
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top