Searching value in all of the sheets - excel

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: