Go Premium for a chance to win a PS4. Enter to Win

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 215
  • Last Modified:

Excel VBA to list all of the workbook formulas in a seperate sheet

Hello,

i need help with VBA code that lists all of the activeworkbook formulas into a new sheet


thanks.
0
Flora
Asked:
Flora
  • 8
  • 6
1 Solution
 
Pratik MakwanaCommented:
Below Macro Copy all formula of Sheet1 to Sheet2 in same cells....
Sub FormulaCopy()
Dim rng As Range, Dest, Source As String
For Each rng In Sheets("Sheet1").Cells.SpecialCells(xlCellTypeFormulas)
    Dest = rng.Address
    Source = rng.Formula
    Sheets("Sheet2").Range(Dest).Formula = Source
Next
End Sub

Open in new window

0
 
Rory ArchibaldCommented:
What exactly do you want as the output - a list of all the distinct formulas, or just every formula? Is that all the information you want?
0
 
FloraAuthor Commented:
Thanks Rory,

i want all formulas.  

i had found this code in internet from Jonhn Walkenbatch but it is too slow, it freezes, i wanted a faster one. becuase the excel sheet that i am trying to extract its formulas in another sheet as text, is heavily populated with too many formuals.

Sub ListFormulas()
    Dim FormulaCells As Range, Cell As Range
    Dim FormulaSheet As Worksheet
    Dim Row As Integer
    
'   Create a Range object for all formula cells
    On Error Resume Next
    Set FormulaCells = Range("A1").SpecialCells(xlFormulas, 23)
    
'   Exit if no formulas are found
    If FormulaCells Is Nothing Then
        MsgBox "No Formulas."
        Exit Sub
    End If
    
'   Add a new worksheet
    Application.ScreenUpdating = False
    Set FormulaSheet = ActiveWorkbook.Worksheets.Add
    FormulaSheet.Name = "Formulas in " & FormulaCells.Parent.Name
    

'   Set up the column headings
    With FormulaSheet
        Range("A1") = "Address"
        Range("B1") = "Formula"
        Range("C1") = "Value"

        Range("A1:C1").Font.Bold = True
    End With
    
'   Process each formula
    Row = 2
    For Each Cell In FormulaCells
        Application.StatusBar = Format((Row - 1) / FormulaCells.Count, "0%")
        With FormulaSheet
            Cells(Row, 1) = Cell.Address _
                (RowAbsolute:=False, ColumnAbsolute:=False)
            Cells(Row, 2) = " " & Cell.Formula
            Cells(Row, 3) = Cell.Value
            Row = Row + 1
        End With
    Next Cell
    
'   Adjust column widths
    FormulaSheet.Columns("A:C").AutoFit
    Application.StatusBar = False
End Sub

Open in new window

0
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

 
Rory ArchibaldCommented:
So you only want the formulas and not the location?
0
 
FloraAuthor Commented:
i want in first column of new sheet,  Formula that is stored with ' Apostrophe as text and then next column the cell/sheet location address of the formula. that is it.
0
 
Rory ArchibaldCommented:
Try this:

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

    Application.ScreenUpdating = False

    lRow = 2

    Set dic = CreateObject("Scripting.Dictionary")


    For Each ws In ActiveWorkbook.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


            '   Process each formula
            For Each Cell In FormulaCells
                dic.Add ws.Name & "!" & Cell.Address(0, 0), "'" & Cell.Formula
            Next Cell
        End If
    Next ws

    If dic.Count <> 0 Then
        '   Add a new worksheet
        On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets("Formula list").Delete
        Application.DisplayAlerts = True
        On Error GoTo 0
        Set FormulaSheet = ActiveWorkbook.Worksheets.Add
        FormulaSheet.Name = "Formula list"

        '   Set up the column headings
        FormulaSheet.Range("A1:B1") = Array("Address", Formula)
        vFormulas = Application.Index(Array(dic.keys, dic.items), 0, 0)
        FormulaSheet.Range("A2").Resize(UBound(vFormulas, 2), UBound(vFormulas, 1)).Value = Application.Transpose(vFormulas)
        '   Adjust column widths
        FormulaSheet.Columns("A:B").AutoFit
    End If
End Sub

Open in new window

0
 
FloraAuthor Commented:
thanks Rory,

but the debugger stopped at line 46 vFormulas = Application.Index(Array(dic.keys, dic.items), 0, 0)
vFormulas = Application.Index(Array(dic.keys, dic.items), 0, 0)

Open in new window

0
 
Rory ArchibaldCommented:
Roughly how many formulas are you dealing with - more than 65000?
0
 
Rory ArchibaldCommented:
If you have up to 65000 odd formulas on any one sheet, you can use this version:

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

    Application.ScreenUpdating = False

    lRow = 2

    Set dic = CreateObject("Scripting.Dictionary")


    '   Add a new worksheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Formula list").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Set FormulaSheet = ActiveWorkbook.Worksheets.Add
    FormulaSheet.Name = "Formula list"

    '   Set up the column headings
    FormulaSheet.Range("A1:B1") = Array("Address", Formula)
    For Each ws In ActiveWorkbook.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


            '   Process each formula
            For Each Cell In FormulaCells
                dic.Add ws.Name & "!" & Cell.Address(0, 0), "'" & Cell.Formula
            Next Cell

        End If

        If dic.Count <> 0 Then
            vFormulas = Application.Index(Array(dic.keys, dic.items), 0, 0)
            FormulaSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(vFormulas, 2), UBound(vFormulas, 1)).Value = Application.Transpose(vFormulas)
            '   Adjust column widths
        End If
        dic.RemoveAll
        Set FormulaCells = Nothing
    Next ws
    FormulaSheet.Columns("A:B").AutoFit
End Sub

Open in new window

0
 
FloraAuthor Commented:
yes, Rory. the formulas are couple of thousands

the latest code stopped at line 46  error 13
type mismatch
code             vFormulas = Application.Index(Array(dic.keys, dic.items), 0, 0)
0
 
Rory ArchibaldCommented:
Any chance you can post the workbook so I can see what's going on?
0
 
Rory ArchibaldCommented:
Third version for testing in the meantime:

Sub ListFormulas()
    Dim ws                    As Worksheet
    Dim FormulaCells          As Range
    Dim Cell                  As Range
    Dim FormulaSheet          As Worksheet
    Dim dic                   As Object

    Application.ScreenUpdating = False

    Set dic = CreateObject("Scripting.Dictionary")


    '   Add a new worksheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Formula list").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Set FormulaSheet = ActiveWorkbook.Worksheets.Add
    FormulaSheet.Name = "Formula list"

    '   Set up the column headings
    FormulaSheet.Range("A1:B1") = Array("Formula", "Address")
    For Each ws In ActiveWorkbook.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


            '   Process each formula
            For Each Cell In FormulaCells
                dic.Add ws.Name & "!" & Cell.Address(0, 0), "'" & Cell.Formula
            Next Cell

        End If

        If dic.Count <> 0 Then
            With FormulaSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(dic.Count, 1)
                .Value = Application.Transpose(dic.items)
                .Offset(, 1).Value = Application.Transpose(dic.keys)
            End With
            '   Adjust column widths
        End If
        dic.RemoveAll
        Set FormulaCells = Nothing
    Next ws
    FormulaSheet.Columns("A:B").AutoFit
End Sub

Open in new window

0
 
FloraAuthor Commented:
Thanks Rory,

same mismatch error now this time at line 43                 .Value = Application.Transpose(dic.items)

sorry, i wish i could share the workbook here , A) it is too big to upload, B) it has some private company employee names etc as data which i am not allowed to share.
0
 
Rory ArchibaldCommented:
Do you have any really long formulas? What does dic.count return when the code breaks?
0
 
FloraAuthor Commented:
the return is nothing, all I get is a new sheet with the A1 cell "Address"  that is it. I do not see anything else.

by the way,  if this is too much, I will try to break the data into 4 or 5 piece and then run your first code.

your first code already helped me.

so, I do not want cause trouble for you.  I like you very much, as you have helped me many times.
0

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 8
  • 6
Tackle projects and never again get stuck behind a technical roadblock.
Join Now