Macro to Identify Hardcoded numbers in formulas ....

A

actjfc

Active Member
Joined
Jun 28, 2003
Messages
416
Hi dear Excel gurus!

I would like somebody to help me to develop a macro (or do it for me :oops: ) that makes a list of all cell addresses that contain hardcoded numbers that are used within an entire workbook. An example will be:


Cell B28 = A1*3*C14 => Hardcoded number is = 3

Cell B30 = (1+.08)^B15 => Hardcoded number is = 0.08


Cell B40 = (1+B3)^2 => Hardcoded number is = 3

An so on…


The macro output must list in sheet "n" (n>3)

Sheet 1 - B28 Text= A1*3*C14
Sheet 2 – B30 Text = (1+.08)^B15
Sheet 3 – B40 Text = (1+B3)^2

It would be ideal if it actually shows the cell address and the text formula with the hardcoded number in it.

Thanks!

actjfc
 
Sort by date Sort by votes
Hi actjfc

I added the creation of the worksheet "HCN" (for HardCoded Number) if it does not exist. If it exists it's cleared.

Before doing other changes I want to fix the error you mention. I could not reproduce your error.

In fact I tried
=B4+B5, =B4+B5+B6,=B4*B5,=B4/B5^B6

and none appeared in the result since these formulas don't have hardcoded numbers, just cell addresses.

Only in the case of, for example
=B4+B5+2.3
does the formula appear, since it has the number 2.3

Can you please post the EXACT formulas that don't have hardcoded numbers but appear in the result?

Best regards
PGC

Code: 
Option Explicit
Const sNumber As String = "(?:[=,;{\+\-\/\*\^\(])(\d+(?:\.\d+)?(?:E[\-\+]?\d+)?)(?=$|[%=,;}\+\-\/\*\^\)])" ' Number
Const sDoubleSingleQuotedString As String = "(\""[^\""]*\"")|('[^'\""]*')" ' Double- and single quoted strings

Sub FormulaHasNumber()
Dim ws As Worksheet, rFormula As Range, rFormulas As Range
Dim rConstant As Range, rConstants As Range, rResult As Range
Dim RegExQS As Object, RegExN As Object, oMatches As Object, iMatch As Integer

Set RegExQS = CreateObject("VBSCRIPT.REGEXP")
RegExQS.Pattern = sDoubleSingleQuotedString
RegExQS.Global = True
Set RegExN = CreateObject("VBSCRIPT.REGEXP")
RegExN.Pattern = sNumber
RegExN.Global = True

On Error Resume Next
Set ws = Worksheets("HCN")
If ws Is Nothing Then
    Err.Clear
    With Sheets.Add(after:=Sheets(Sheets.Count))
        .Name = "HCN"
    End With
Else
    Worksheets("HCN").UsedRange.ClearContents
End If
Worksheets("HCN").Range("A1:D1") = Array("Worksheet", "Address", "Formula", "Hardcoded Numbers")

For Each ws In Worksheets
    Set rFormulas = ws.UsedRange.SpecialCells(xlCellTypeFormulas)
    If Err Then
        Err.Clear
    Else
        For Each rFormula In rFormulas
            Set oMatches = RegExN.Execute(RegExQS.Replace(rFormula.Formula, ""))
            If oMatches.Count > 0 Then
                Set rResult = Worksheets("HCN").Range("A" & Rows.Count).End(xlUp).Offset(1)
                rResult = rFormula.Worksheet.Name
                rResult.Offset(, 1) = rFormula.Address
                rResult.Offset(, 2) = "'" & rFormula.Formula
                rResult.Offset(, 3) = "'" & oMatches(0).submatches(0)
                For iMatch = 1 To oMatches.Count - 1
                    rResult.Offset(, 3) = rResult.Offset(, 3) & ", " & oMatches(iMatch).submatches(0)
                Next
            End If
        Next
    End If
    Set rConstants = ws.UsedRange.SpecialCells(xlCellTypeConstants, xlNumbers)
    If Err Then
        Err.Clear
    Else
        For Each rConstant In rConstants
            Set rResult = Worksheets("HCN").Range("A" & Rows.Count).End(xlUp).Offset(1)
            rResult = rConstant.Worksheet.Name
            rResult.Offset(, 1) = rConstant.Address
            rResult.Offset(, 3) = "'" & rConstant.Value
        Next
    End If
Next
End Sub
 
Upvote 0

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
pgc01,

I could not reproduce the "error", and now the macro is working fine :oops:. Please, exclude the Date and Time formatted cells, and any bold blue cells, and it will be done.

I have realized that my models have too many "good" cells containing formulas with an isolated "1"* as a hard coded number.

I think to develop an outstanding macro, it will also need the possibility to exclude from the list cells containing an user chosen "isolated" figure, in my situation the number "1", as an optional feature that may be turned off (by modifying, deleting or skipping some lines in the macro code).

I really appreciate your help! I am impatient to run the final version.

Thanks!

actjfc

* Example:
=(1-b2)^b5
=c15+1
 
Upvote 0
Hi actjfc

I've excluded Date and Time formatted cells. Please test it.

I could not exclude the blue cells because you didn't tell me which blue you use. Please tell me the ColorIndex value.

Also you say bold blue cells. Does it mean that the cells are blue and the font is bold?

If there are still Date and Time formatted cells in the result post their exact number fotmat.

Kind regards
PGC

Code: 
Option Explicit
Const sNumber As String = "(?:[=,;{\+\-\/\*\^\(])(\d+(?:\.\d+)?(?:E[\-\+]?\d+)?)(?=$|[%=,;}\+\-\/\*\^\)])" ' Number
Const sDoubleSingleQuotedString As String = "(\""[^\""]*\"")|('[^'\""]*')" ' Double- and single quoted strings

Sub FormulaHasNumber()
Dim ws As Worksheet, rFormula As Range, rFormulas As Range
Dim rConstant As Range, rConstants As Range, rResult As Range
Dim RegExQS As Object, RegExN As Object, oMatches As Object, iMatch As Integer

Set RegExQS = CreateObject("VBSCRIPT.REGEXP")
RegExQS.Pattern = sDoubleSingleQuotedString
RegExQS.Global = True
Set RegExN = CreateObject("VBSCRIPT.REGEXP")
RegExN.Pattern = sNumber
RegExN.Global = True

On Error Resume Next
Set ws = Worksheets("HCN")
If ws Is Nothing Then
    Err.Clear
    With Sheets.Add(after:=Sheets(Sheets.Count))
        .Name = "HCN"
    End With
Else
    Worksheets("HCN").UsedRange.ClearContents
End If
Worksheets("HCN").Range("A1:D1") = Array("Worksheet", "Address", "Formula", "Hardcoded Numbers")

For Each ws In Worksheets
    Set rFormulas = ws.UsedRange.SpecialCells(xlCellTypeFormulas)
    If Err Then
        Err.Clear
    Else
        For Each rFormula In rFormulas
            If IsValid(rFormula) Then
                Set oMatches = RegExN.Execute(RegExQS.Replace(rFormula.Formula, ""))
                If oMatches.Count > 0 Then
                    Set rResult = Worksheets("HCN").Range("A" & Rows.Count).End(xlUp).Offset(1)
                    rResult = rFormula.Worksheet.Name
                    rResult.Offset(, 1) = rFormula.Address
                    rResult.Offset(, 2) = "'" & rFormula.Formula
                    rResult.Offset(, 3) = "'" & oMatches(0).submatches(0)
                    For iMatch = 1 To oMatches.Count - 1
                        rResult.Offset(, 3) = rResult.Offset(, 3) & ", " & oMatches(iMatch).submatches(0)
                    Next
                End If
            End If
        Next
    End If
    Set rConstants = ws.UsedRange.SpecialCells(xlCellTypeConstants, xlNumbers)
    If Err Then
        Err.Clear
    Else
        For Each rConstant In rConstants
            If IsValid(rConstant) Then
                Set rResult = Worksheets("HCN").Range("A" & Rows.Count).End(xlUp).Offset(1)
                rResult = rConstant.Worksheet.Name
                rResult.Offset(, 1) = rConstant.Address
                rResult.Offset(, 3) = "'" & rConstant.Value
            End If
        Next
    End If
Next
End Sub

Function IsValid(rCell As Range) As Boolean
Dim sFormat As String

' If format is date or time return false
sFormat = rCell.NumberFormat
With CreateObject("VBSCRIPT.REGEXP")
    .Global = True
    .Pattern = "(\""[^\""]*\"")|\\."
    sFormat = .Replace(sFormat, "")
    .Pattern = "[ymdhms]"
    If .test(sFormat) Then Exit Function
End With
IsValid = True
End Function
 
Upvote 0
Testing

pgc01,

I tested using this:
Book2
BCDE
31234
4
526716
6
7456716
8
912/10/06
Sheet1


and the result is:
Book2
ABCDE
1WorksheetAddressFormulaHardcodedNumbers
2Sheet1$B$5=B3+1
3Sheet1$C$5=C3*D3
4Sheet1$D$5=D3+E3
5Sheet1$E$5=E3^2
6Sheet1$C$7=C5
7Sheet1$D$7=D5
8Sheet1$E$7=E5
HCN


Now, it is not working! :(

I do not know much about color codes or time or date codes. What I always use is the color tool bar this way: I open it, and push the 2nd row 6th square on the righ (the blue one), then push the "B" on the format tool bar to bold the font in the cell. Regarding the Date and Time I use most of the format types, but more often I use MM/DD/YY.

Thanks!

actjfc
 
Upvote 0
Hi Richard

I'd be very glad if you would use the code in your work environment. I'm not worried about you claiming the credit for the code, you'll surely have to adapt it to your needs and so it will be yours.

Please share any improvements you make.

Cheers
PGC
 
Upvote 0
Hi actjfc

I added the code to exclude cells with font blue (colorindex=5) and bold.

I don't understand the results in your post. I could not reproduce any of those errors.

Please test the code in a new, clean workbook and post back the result.

Kind regards
PGC

Code: 
Option Explicit
Const sNumber As String = "(?:[=,;{\+\-\/\*\^\(])(\d+(?:\.\d+)?(?:E[\-\+]?\d+)?)(?=$|[%=,;}\+\-\/\*\^\)])" ' Number
Const sDoubleSingleQuotedString As String = "(\""[^\""]*\"")|('[^'\""]*')" ' Double- and single quoted strings

Sub FormulaHasNumber()
Dim ws As Worksheet, rFormula As Range, rFormulas As Range
Dim rConstant As Range, rConstants As Range, rResult As Range
Dim RegExQS As Object, RegExN As Object, oMatches As Object, iMatch As Integer

Set RegExQS = CreateObject("VBSCRIPT.REGEXP")
RegExQS.Pattern = sDoubleSingleQuotedString
RegExQS.Global = True
Set RegExN = CreateObject("VBSCRIPT.REGEXP")
RegExN.Pattern = sNumber
RegExN.Global = True

On Error Resume Next
Set ws = Worksheets("HCN")
If ws Is Nothing Then
    Err.Clear
    With Sheets.Add(after:=Sheets(Sheets.Count))
        .Name = "HCN"
    End With
Else
    Worksheets("HCN").UsedRange.ClearContents
End If
Worksheets("HCN").Range("A1:D1") = Array("Worksheet", "Address", "Formula", "Hardcoded Numbers")

For Each ws In Worksheets
    Set rFormulas = ws.UsedRange.SpecialCells(xlCellTypeFormulas)
    If Err Then
        Err.Clear
    Else
        For Each rFormula In rFormulas
            If IsValid(rFormula) Then
                Set oMatches = RegExN.Execute(RegExQS.Replace(rFormula.Formula, ""))
                If oMatches.Count > 0 Then
                    Set rResult = Worksheets("HCN").Range("A" & Rows.Count).End(xlUp).Offset(1)
                    rResult = rFormula.Worksheet.Name
                    rResult.Offset(, 1) = rFormula.Address
                    rResult.Offset(, 2) = "'" & rFormula.Formula
                    rResult.Offset(, 3) = "'" & oMatches(0).submatches(0)
                    For iMatch = 1 To oMatches.Count - 1
                        rResult.Offset(, 3) = rResult.Offset(, 3) & ", " & oMatches(iMatch).submatches(0)
                    Next
                End If
            End If
        Next
    End If
    Set rConstants = ws.UsedRange.SpecialCells(xlCellTypeConstants, xlNumbers)
    If Err Then
        Err.Clear
    Else
        For Each rConstant In rConstants
            If IsValid(rConstant) Then
                Set rResult = Worksheets("HCN").Range("A" & Rows.Count).End(xlUp).Offset(1)
                rResult = rConstant.Worksheet.Name
                rResult.Offset(, 1) = rConstant.Address
                rResult.Offset(, 3) = "'" & rConstant.Value
            End If
        Next
    End If
Next
End Sub

Function IsValid(rCell As Range) As Boolean
Dim sFormat As String

With rCell.Font
    If .ColorIndex = 5 And .Bold = True Then Exit Function
End With

' If format is date or time return false
sFormat = rCell.NumberFormat
With CreateObject("VBSCRIPT.REGEXP")
    .Global = True
    .Pattern = "(\""[^\""]*\"")|\\."
    sFormat = .Replace(sFormat, "")
    .Pattern = "[ymdhms]"
    If .test(sFormat) Then Exit Function
End With
IsValid = True
End Function
 
Upvote 0
You got it!

A big THANK YOU! :p You got it!

I had an issue with the "personal.xls" and "thisworkbook". I fixed it and your macro is running perfectly.

The macro identifies any hard coded number inside any cell, be it an isolated number or inside a formula. Also, it excludes date, time and blue formats. Perfect!

My concern above about the "1" is easy to solve. I will just sort the HCN output list, and delete any unwanted repeated rows.

If I find any bugs later this month after testing it with diferent models, I will reopen the post. However, at this time I think it is runing just fine. Extra kudos to you!

Thanks!

actjfc
 
Upvote 0
Hi actjfc

Great! Everything works!

This was very interesting.
About the 1s. I also think it's better to deal with them directly in the worksheet. You can delete them or hide them with autofilter.

Cheers
PGC
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
VBA macro: How to identify column by name (instead of number) before filling
Replies
3
Views
98
rpaulson
rpaulson
k3yn0t3
  • Solved
INDEX(MATCH()) pulling wrong row data & Macro to duplicate sheets with formulas
Replies
4
Views
364
Alex Blakenburg
A
B
  • Question
If sheet title is NOT this Monday's date then execute code
Replies
3
Views
372
MARK858
MARK858
esset
  • Solved
Splitting hours worked into multiple shift patterns
Replies
3
Views
540
esset
esset
C
  • Question
Getting the cell address of a sheet cell from the Change Event of a Listbox1's code n = Listbox1.Listindex
Replies
5
Views
275
Legacy 143009
L

Forum statistics

Threads
1,214,375
Messages
6,119,166
Members
448,870
Latest member
max_pedreira

Share this page

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