VBA for getting a list of all formulas not in a table, and only the first row of a table

[trishcollins]

Okay, so I have working on VBA code to extract ALL formulas from a single cell if not in a table, and only the first row of formulas in any table (since all the remaining rows are the same formula). Initially, I had code working to extract ALL formulas, then modified it as follows. Given that I found this code on the Internet, and modified for my needs, I am somehow doing something wrong. The first thing, it is not creating the "Formula List
worksheet. The second thing is stops at the first instance of "dic.Add ws.Name & "!" & Cell.Address(0, 0), "'" & Cell.Formula", when following the correct IF THEN ELSE path, for a cell that is not in a table. Any ideas what I am doing wrong?

Sub ListFormulas()
Dim ws As Worksheet
Dim FormulaCells As Range: Dim Cell As Range
Dim FormulaSheet As Worksheet
Dim lRow As Long
Dim dic As Object
Dim vFormulas As Variant: Dim vFormulas1 As Variant
Dim EquivRange As Range, r As Range
Dim lo As ListObject
Dim nFirstRow As Long, nLastRow As Long
Dim TableName As ListObject

Application.ScreenUpdating = False
lRow = 2
Set dic = CreateObject("Scripting.Dictionary")
Set dic1 = CreateObject("Scripting.Dictionary")
MsgBox ("Worksheet Created")
For Each ws In ActiveWorkbook.Worksheets
    If ws.Name <> "Formula list" And ws.Name <> "Formulas" And ws.Name <> "Data Validation List" Then 'don't include these worksheets
        ' Create a Range object for all formula cells
        On Error Resume Next
        Set FormulaCells = ws.UsedRange.SpecialCells(xlFormulas)
        On Error GoTo 0
        ' Exit if no formulas are found
        If Not FormulaCells Is Nothing Then 'Check to see if there is a formula in the cell
            If ActiveCell.ListObject Is Nothing Then  'Check to see if this cell is in a table and if not, get the formula
                Set FormulaCells = ws.UsedRange.SpecialCells(xlFormulas)
                    dic.Add ws.Name & "!" & Cell.Address(0, 0), "'" & Cell.Formula
                    dic1.Add ws.Name & "!" & Cell.Address(0, 0), Cell.Value
            Else
                Set TableName = ActiveCell.ListObjects.Name 'Get the name of the table of the current cell
                Set EquivRange = ws.ListObjects(TableName).DataBodyRange.Rows(

 

[StephenCrump]

The second thing is stops at the first instance of "dic.Add ws.Name & "!" & Cell.Address(0, 0), "'" & Cell.Formula"

I assume you mean the code stops with an error message? Because your code hasn't set a value for Cell.

The first thing, it is not creating the "Formula List

Your code is referring to ActiveCell, which is static. You'll need to loop through FormulaCells, along these lines:

If Not FormulaCells Is Nothing Then
    For Each r In FormulaCells
        If r.ListObject Is Nothing Then
            dic.Add ws.Name & "!" & r.Address(0, 0), "'" & r.Formula
            dic1.Add ws.Name & "!" & r.Address(0, 0), r.Value
        Else
            ......

 

[trishcollins]

I assume you mean the code stops with an error message? Because your code hasn't set a value for Cell.


Your code is referring to ActiveCell, which is static. You'll need to loop through FormulaCells, along these lines:

If Not FormulaCells Is Nothing Then
    For Each r In FormulaCells
        If r.ListObject Is Nothing Then
            dic.Add ws.Name & "!" & r.Address(0, 0), "'" & r.Formula
            dic1.Add ws.Name & "!" & r.Address(0, 0), r.Value
        Else
            ......

What is "r" defined as?

 

[trishcollins]

What is "r" defined as?

Nevermind

 

[Alex Blakenburg]

Stephen is in Australia and unlikley to be online this late.
Dim r as Range
specifically a cell in FormulaCells as you loop through all the cells that make up FormulaCells.
Just saw your latest post and it sounds like you just worked that out.

 

[trishcollins]

Okay, now I am stuck on this code. If the range is part of a named table, I want the range to be changed to just the first row and only report on cells with formulas. If is picking up the table name no problem. The TableRange (dim as Range), which is supposed to set the new range to just the first row of a table, is not picking up anything, and it's then failing. Any suggestions?

            If Not ws.UsedRange.ListObject Is Nothing Then
                TableName = ws.UsedRange.ListObject.Name
[I][B]                Set TableRange = ws.ListObjects(TableName).DataBodyRange.Rows(1)[/B][/I]
[B][I]                Set FormulaCells = TableRange.SpecialCells(xlFormulas)[/I][/B]
                For Each r In Range(FormulaCells)
                    dic.Add ws.Name & "!" & r.Address(0, 0), "'" & r.Formula
                    dic1.Add ws.Name & "!" & r.Address(0, 0), r.Value
                Next r
            End If

Trish

 

[StephenCrump]

Try:

For Each ws In ActiveWorkbook.Worksheets
    If ws.Name <> "Formula list" And ws.Name <> "Formulas" And ws.Name <> "Data Validation List" Then 'don't include these worksheets
        
        ' Create a Range object for all formula cells
        On Error Resume Next
        Set FormulaCells = ws.UsedRange.SpecialCells(xlFormulas)
        On Error GoTo 0
        
        ' Exit if no formulas are found
        If Not FormulaCells Is Nothing Then 'Check to see if there is a formula in the cell
             For Each r In FormulaCells
                If r.ListObject Is Nothing Then
                    dic.Add ws.Name & "!" & r.Address(0, 0), "'" & r.Formula
                    dic1.Add ws.Name & "!" & r.Address(0, 0), r.Value
                Else
                    If r.Row = r.ListObject.DataBodyRange.Row Then
                        dic.Add ws.Name & "!" & r.Address(0, 0), "'" & r.Formula
                        dic1.Add ws.Name & "!" & r.Address(0, 0), r.Value
                    End If
                End If
            Next r
        End If
    End If
Next ws

 

[trishcollins]

For Each ws In ActiveWorkbook.Worksheets If ws.Name <> "Formula list" And ws.Name <> "Formulas" And ws.Name <> "Data Validation List" Then 'don't include these worksheets ' Create a Range object for all formula cells On Error Resume Next Set FormulaCells = ws.UsedRange.SpecialCells(xlFormulas) On Error GoTo 0 ' Exit if no formulas are found If Not FormulaCells Is Nothing Then 'Check to see if there is a formula in the cell For Each r In FormulaCells If r.ListObject Is Nothing Then dic.Add ws.Name & "!" & r.Address(0, 0), "'" & r.Formula dic1.Add ws.Name & "!" & r.Address(0, 0), r.Value Else If r.Row = r.ListObject.DataBodyRange.Row Then dic.Add ws.Name & "!" & r.Address(0, 0), "'" & r.Formula dic1.Add ws.Name & "!" & r.Address(0, 0), r.Value End If End If Next r End If End If Next ws

That worked like a charm. Thanks.
Question, the "If r.Row = r.ListObject.DataBodyRange.Row", is what I am assuming it figures out what row it is in. But I am not sure how it knows it in the first row of the DataBodyRange. Can you explain, so I understand?

Cheers, Trish

 

[trishcollins]

Also, I have a couple of info tables, where there are formulas, but they are not repeated. Its it possible to also check to see if the second row is different, and if so, add all the formulas from the specific table as well. I can actually name the tables in the "If statement" as well, but it would be cleaner not to have to list the specific tables.

I have tried this specific code, but I get an error, so not sure what I am doing wrong.

If r.ListObject Is Nothing Or r.ListObject.Name = "Menu" Or r.ListObject.Name = "How_It_Works" Then

Trish

 

[trishcollins]

Fixed. I did this instead:

Sub ListUniqueFormulas()
Dim ws As Worksheet
Dim FormulaCells As Range: Dim Cell As Range
Dim FormulaSheet As Worksheet
Dim lRow As Long
Dim dic As Object
Dim vFormulas As Variant: Dim vFormulas1 As Variant
Dim r As Range
Dim TblName As String

Application.ScreenUpdating = False
lRow = 2
Set dic = CreateObject("Scripting.Dictionary")
Set dic1 = CreateObject("Scripting.Dictionary")
'MsgBox ("Worksheet Created")
For Each ws In ActiveWorkbook.Worksheets
    If ws.Name <> "Formula list" And ws.Name <> "Formulas" And ws.Name <> "Data Validation List" Then 'don't include these worksheets
        
        ' Create a Range object for all formula cells
        On Error Resume Next
        Set FormulaCells = ws.UsedRange.SpecialCells(xlFormulas)
        On Error GoTo 0
        
        ' Exit if no formulas are found
        If Not FormulaCells Is Nothing Then 'Check to see if there is a formula in the cell
             For Each r In FormulaCells
                If r.ListObject Is Nothing Then
                    dic.Add ws.Name & "!" & r.Address(0, 0), "'" & r.Formula
                    dic1.Add ws.Name & "!" & r.Address(0, 0), r.Value
                Else
                                    TblName = r.ListObject.Name
                    If TblName = "Menu" Or TblName = "How_It_Works" Or TblName = "Matrix_Totals" Then
                            dic.Add ws.Name & "!" & Cell.Address(0, 0), Cell.Validation.Formula
                            dic1.Add ws.Name & "!" & Cell.Address(0, 0), Cell.Value
                    Else

  &nbsp