Search workbook and list sheet names where found

[hutchisd]

I have a workbook with 105 sheets in it and I need a way of searching for a particular string of numbers through all sheets and have the sheet names where the string is found returned in a list on a new sheet. I have this code from another post that gets me started:

Private Function SheetExists(SheetName As String) As Boolean
' Returns TRUE if a sheet exists in the active workbook
Dim x As Worksheet
On Error Resume Next
Set x = ActiveWorkbook.Sheets(SheetName)
If Err = 0 Then SheetExists = True _
Else SheetExists = False
End Function
Sub FindAllSheets()
Dim Found As Range, ws As Worksheet, LookFor As Variant
LookFor = InputBox("Enter value to find")

If LookFor = "" Then Exit Sub

' Clear or Add a Results sheet
If SheetExists("Search Results") Then
Sheets("Search Results").Activate
Range("A2").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.ClearContents
Else
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Search Results"
End If

For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Search Results" Then
Set Found = ws.Cells.Find(What:=LookFor)
If Found Is Nothing Then
Range("D5").Select
Else
Found.EntireRow.Copy Sheets("Search results").Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
End If
Next ws
End Sub

 

[Legacy 68668]

try

Sub test()
Dim r As Range, ws As Worksheet, txt As String, myStr As String
On Error Resume Next
Application.DisplayAlerts = False
Sheets("myResult").Delete
Application.DisplayAlerts = True
Sheets.Add.Name = "myResult"
On Error GoTo 0
myStr = "12345"
For Each ws In Sheets
    If ws.Name <> "myResult" Then
        Set r = ws.Cells.Find(myStr,,,xlPart)
        If Not r Is Nothing Then txt = txt & vbLf & ws.Name
    End If
    Set r = Nothing
Next
If Len(txt) Then
    x = Split(Mid(txt, 2), vbLf)
    Sheets("myResult").Cells(1).Resize(UBound(x) + 1).Value = _
    Application.Tranapose(x)
Else
    MsgBox myStr & "is not found"
End If
End Sub

 

[hutchisd]

Thanks! I made a few slight modifications so I'll have a message prompt for my search items.

Sub Tab_Report_Search()
Dim r As Range, ws As Worksheet, txt As String, myStr As String
On Error Resume Next
Application.DisplayAlerts = False
Sheets("myResult").Delete
Application.DisplayAlerts = True
Sheets.Add.Name = "myResult"
On Error GoTo 0

myStr = InputBox("Enter value to find")
For Each ws In Sheets
    If ws.Name <> "myResult" Then
        Set r = ws.Cells.Find(myStr, , , xlPart)
        If Not r Is Nothing Then txt = txt & vbLf & ws.Name
    End If
    Set r = Nothing
Next
If Len(txt) Then
    x = Split(Mid(txt, 2), vbLf)
    Sheets("myResult").Cells(1).Resize(UBound(x) + 1).Value = _
    Application.Transpose(x)
Else
    MsgBox myStr & "is not found"
End If
End Sub