Searching value in all of the sheets

Question

The code i've provided here is able to search Sheet1 and then copy the value ( the whole row containing the value) that has been searched into a new sheet and then rename the sheet after search string.

But now i am trying to search all of the sheet in excel instead of one sheet, and this time i am also required to include the header of the relevant row.

for example if i search Apple, the macro will search all the sheet for Apple, and for example if apple is found on sheet7, it will be copied in a new sheet named "Apple" with the relevant header.

But example if there are both apple on sheet7 and sheet8, both will be copied into a new sheet name "Apple" but both of the header must also be copied into the new sheet.

How do i start working on it? i know i have to find out the number of sheets and loop it but after that what should i include?

   Dim strSearch
   Dim rg As Range, rgF As Range
   Dim i As Integer
   Dim celltxt As String
   Dim strSearch2
   'Dim x, NumberOfWorksheet As Integer 'to count worksheet for loop
   Application.ScreenUpdating = False

   strSearch = Application.InputBox("Please enter the search string")
   strSearch2 = Replace(strSearch, "*", " ")
  ' NumberOfWorksheet = ThisWorkbook.Sheets.Count

  ' For x = 0 To NumberOfWorksheet
   If Len(strSearch) > 0 Then
   Worksheets.Add().Name = strSearch2
   Set rg = Sheets("Sheet1").Cells(1).CurrentRegion                                       'Define whole search range here
   For i = 1 To rg.Rows.Count                                                                'we look rows by rows (to copy row once only)

      Set rgF = rg.Rows(i).Find(strSearch, , xlValues, xlWhole)
      If Not rgF Is Nothing Then

         rg.Rows(i).Copy Sheets(strSearch2).Range("A60000").End(xlUp).Offset(1, 0)
         Set rgF = Nothing
      End If
   Next i
   'Next x
   Application.ScreenUpdating = True
   End If

Answer 1

It has worked on Excel 2007:

Sub sof20312498SearchCopy()

  Dim i As Long, nRowsAddePerSheet As Long, nRows As Long, _
    nRowsMax As Long, nSheets As Long
  
  Dim strSearch, strSearch2
  
  Dim rg As Range, rgF As Range
  Dim wks
  '
  'Dim x, NumberOfWorksheet As Integer 'to count worksheet for loop
  Dim x
  '
  strSearch = Application.InputBox("Please enter the search string")
  strSearch2 = Replace(strSearch, "*", "")
  If Len(strSearch2) <= 0 Then
    MsgBox "Abandon: Search string must not be empty."
    Exit Sub
  End If
  
  Application.ScreenUpdating = False

  nSheets = Sheets.Count
  nRowsMax = ActiveSheet.Rows.Count
  
  For x = 1 To nSheets
    '
    ' get the worksheet, if nonexistent, add it:
    '
    On Error Resume Next
    Set wks = Worksheets(strSearch2)
    If (Err) Then
      Set wks = Worksheets.Add(After:=Sheets(Sheets.Count))
      wks.Name = strSearch2
      Err.Clear
    End If
    On Error GoTo 0
    '
    ' Define whole search range here:
    '
    'Set rg = Sheets("Sheet1").Cells(1).CurrentRegion
    '
    Sheets(x).Activate
    Set rg = ActiveSheet.Cells(1).CurrentRegion
    '
    ' we look rows by rows (to copy row once only):
    '
    nRows = rg.Rows.Count
    nRowsAddePerSheet = 0
    For i = 1 To nRows
      Set rgF = rg.Rows(i).Find(strSearch, , xlValues, xlWhole)
      '
      ' if found, copy the source row as the last row of the destination Sheet:
      '
      If Not rgF Is Nothing Then
        '
        ' copy header if required, Row(1) is assumed as header:
        '
        If (nRowsAddePerSheet <= 0) Then
          If (i <> 1) Then
            rg.Rows(1).Copy wks.Range("A" & nRowsMax).End(xlUp).Offset(1, 0)
          End If
        End If
        '
        rg.Rows(i).Copy wks.Range("A" & nRowsMax).End(xlUp).Offset(1, 0)
        nRowsAddePerSheet = nRowsAddePerSheet + 1
      End If
    Next
  Next

  Set rgF = Nothing
  Set rg = Nothing
  Set wks = Nothing

  Application.ScreenUpdating = True
End Sub

For the search string "Apple", Sheet1 and Sheet2 contain it as whole word:

Sheet1

Sheet2

Apple - Here is the Sheet Apple: