List all formulas in a worksheet on a separate worksheet

The code below works to copy formulas and cell addresses for an entire workbook. Can the code be modified to only copy formulas and addresses for a single worksheet with output to a specific (sheet3) worksheet as opposed to creating a new worksheet every time?

I looked up Glaswegian the original author but they have not been logged in since 2016 so I don't think they are active.

Any help would be appreciated.

Code:

---

Sub ListAllFormulas()   
    Dim sht As Worksheet
    Dim shtName
    Dim myRng As Range
    Dim newRng As Range
    Dim c As Range
   
ReTry:
    shtName = Application.InputBox("Choose a name for the new sheet to list all formulas.", "New Sheet Name") 'the user decides the new sheet name
    If shtName = False Then Exit Sub 'exit if user clicks Cancel
   
    On Error Resume Next
    Set sht = Sheets(shtName) 'check if the sheet exists
    If Not sht Is Nothing Then 'if so, send message and return to input box
        MsgBox "This sheet already exists"
        Err.Clear 'clear error
        Set sht = Nothing 'reset sht for next test
        GoTo ReTry 'loop to input box
    End If
   
    Worksheets.Add.Move after:=Worksheets(Worksheets.Count) 'adds a new sheet at the end
    Application.ScreenUpdating = False
    With ActiveSheet 'the new sheet is automatically the activesheet
        .Range("A1").Value = "Formula" 'puts a heading in cell A1
        .Range("B1").Value = "Sheet Name" 'puts a heading in cell B1
        .Range("C1").Value = "Cell Address" 'puts a heading in cell C1
        .Name = shtName 'names the new sheet from InputBox
    End With
   
    For Each sht In ActiveWorkbook.Worksheets 'loop through the sheets in the workbook
        If sht.Name <> shtName Then 'exclude the sheet just created
            Set myRng = sht.UsedRange 'limit the search to the UsedRange
            On Error Resume Next 'in case there are no formulas
            Set newRng = myRng.SpecialCells(xlCellTypeFormulas) 'use SpecialCells to reduce looping further
            For Each c In newRng 'loop through the SpecialCells only
                Sheets(shtName).Range("A65536").End(xlUp).Offset(1, 0).Value = Mid(c.Formula, 2, (Len(c.Formula)))
                'places the formula minus the '=' sign in column A
                Sheets(shtName).Range("B65536").End(xlUp).Offset(1, 0).Value = sht.Name
                'places the sheet name containing the formula in column B
                Sheets(shtName).Range("C65536").End(xlUp).Offset(1, 0).Value = Application.WorksheetFunction.Substitute(c.Address, "$", "")
                'places the cell address, minus the "$" signs, containing the formula in column C
            Next c
        End If
    Next sht
    Sheets(shtName).Activate 'make the new sheet the activesheet
    ActiveSheet.Columns("A:C").AutoFit 'autofit the data
    Application.ScreenUpdating = True
End Sub

---

Hi oam,

You can give the below a try, it assumes you will put the headers in the result sheet (A1:C1). You may also want to include a line of code to clear the result sheet before it adds new results to it:

Code:

---

Sub ListAllFormulas()
    Dim sht As Worksheet, rSheet As Worksheet
    Dim myRng As Range, newRng As Range, c As Range
    Dim endRow As Long
   
    Set rSheet = Sheets("Sheet3") ' results sheet
    Set sht = Sheets("Sheet1") ' sheet to search
    Set myRng = sht.UsedRange 'limit the search to the UsedRange
   
    On Error Resume Next 'in case there are no formulas
    Set newRng = myRng.SpecialCells(xlCellTypeFormulas) 'use SpecialCells to reduce looping further
    For Each c In newRng 'loop through the SpecialCells only
        With rSheet
            endRow = .Range("A" & Rows.Count).End(xlUp).Row + 1 ' sets the next row on the results sheet
            .Range("A" & endRow).Value = Mid(c.Formula, 2, (Len(c.Formula))) 'places the formula minus the '=' sign in column A
            .Range("B" & endRow).Value = sht.Name 'places the sheet name containing the formula in column B
            .Range("C" & endRow).Value = Application.WorksheetFunction.Substitute(c.Address, "$", "") 'places the cell address, minus the "$" signs, containing the formula in column C
        End With
    Next c
    On Error GoTo 0

    rSheet.Columns("A:C").AutoFit 'autofit the data
End Sub

---

Hope this helps

georgiboy,

The code works great!!! :clap::thumb

Thank you so much for your help! :yes