Option Explicit
Sub Macro1()
Dim wb As Workbook
Dim wsDestin As Worksheet, wsSrc As Worksheet
Dim rngMyCell As Range
Dim strFindWhat As String, strFormula As String
Dim lngPasteRow As Long
Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set wsDestin = wb.Sheets("Sheet1") '<-Name of sheet to put the results. Change to suit if necessary.
strFindWhat = wsDestin.Range("B1").Value '<-Cell in sheet 'wsDestin' that has the text to search within formulas for. Change to suit if necessary.
If WorksheetFunction.CountA(wsDestin.Cells) > 0 Then
lngPasteRow = wsDestin.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
Else
lngPasteRow = 3 '<-Starting row for the output if there's no data in 'wsDestin'. Change to suit if necessary.
End If
For Each wsSrc In wb.Sheets
If wsSrc.Name <> wsDestin.Name Then
For Each rngMyCell In wsSrc.UsedRange
If rngMyCell.HasFormula = True Then
strFormula = rngMyCell.Formula
If InStr(strFormula, strFindWhat) > 0 Then
wsDestin.Range("A" & lngPasteRow).Value = wb.Name
wsDestin.Range("B" & lngPasteRow).Value = wsSrc.Name
On Error Resume Next
wsDestin.Range("C" & lngPasteRow).Value = rngMyCell.Name.Name
On Error GoTo 0
wsDestin.Range("D" & lngPasteRow).Value = rngMyCell.Address
wsDestin.Range("E" & lngPasteRow).Value = rngMyCell.Value
wsDestin.Range("F" & lngPasteRow).Value = "'" & rngMyCell.Formula
lngPasteRow = lngPasteRow + 1
End If
End If
Next rngMyCell
End If
Next wsSrc
Application.ScreenUpdating = True
MsgBox "Done", vbInformation
End Sub
