Find text in all sheet & return Sheet Name & Header in new Excel sheet

You can use below code for find particular text in all sheets

'Run from standard module, like: Module1.

    'Find all data on all sheets!

    'Do not search the sheet the found data is copied to!

    'List a message box with all the found data addresses, as well!

    Dim ws As Worksheet, Found As Range

    Dim myText As String, FirstAddress As String

    Dim AddressStr As String, foundNum As Integer



    myText = InputBox("Enter text to find")



    If myText = "" Then Exit Sub



    For Each ws In ThisWorkbook.Worksheets

    With ws

    'Do not search sheet4!



    Set Found = .UsedRange.Find(what:=myText, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)



    If Not Found Is Nothing Then

    FirstAddress = Found.Address



    Do

    foundNum = foundNum + 1

    'AddressStr = AddressStr & .Name & "," & Found.Address & vbCrLf

    AddressStr = AddressStr & .Name & "//" & Found.Address & "//" & ws.Cells(1, Found.Column).Value & ";" & vbCrLf



    Set Found = .UsedRange.FindNext(Found)



    'Copy found data row to sheet4 Option!

    'Found.EntireRow.Copy _

    'Destination:=Worksheets("Sheet4").Range("A65536").End(xlUp).Offset(1, 0)

    Loop While Not Found Is Nothing And Found.Address <> FirstAddress And Found.Column <> Range(FirstAddress).Column

    End If



myNext:

    End With



    Next ws



    If Len(AddressStr) Then

    MsgBox "Found: """ & myText & """ " & foundNum & " times." & vbCr & _

    AddressStr, vbOKOnly, myText & " found in these cells"

   

    Set ws = Sheets.Add(After:=Sheets(Sheets.Count))

    ws.Name = "Report"

   

    Range("A1").Resize(foundNum, 1) = Application.Transpose(Split(AddressStr, ";"))

    Else:



    MsgBox "Unable to find " & myText & " in this workbook.", vbExclamation

    End If

   

    Columns("A:A").AutoFit

End Sub