السلام عليكم
هذا تعديل للكود
سيظهر لك مربع تدخل فيه اسم شيت البحث
ثم مربع ستدخل فيه كلمة البحث
للعلم لابد ان يكون هناك شيت بأسم (PReport) للصق النتائيج فيه
Sub Test2()
Dim myWord$
Mysh = Application.InputBox("What Sheets Name", "Enter Sheets Name")
If Mysh = "" Then Exit Sub
myWord = InputBox("What key word to copy rows", "Enter your word")
If myWord = "" Then Exit Sub
Sheets(Mysh).Select
Application.ScreenUpdating = False
Dim xRow&, NextRow&, LastRow&
NextRow = 2
LastRow = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For xRow = 1 To LastRow
If WorksheetFunction.CountIf(Rows(xRow), "*" & myWord & "*") > 0 Then
Rows(xRow).Copy Sheets("PReport").Rows(NextRow)
NextRow = NextRow + 1
End If
Next xRow
Application.ScreenUpdating = True
MsgBox "Macro is complete, " & NextRow - 2 & " rows containing" & vbCrLf & _
"''" & myWord & "''" & " were copied to Sheet2.", 64, "Done"
Sheets("PReport").Select
End Sub