copy and paste rows from multiple rows that contain certain words

[Somdada]

Hi,
I am looking for a macro that can extract rows from multiple rows that contain certain words.
These rows starts from A1.

Problem
1. Beautiful horses are in the stable
2. Cats are hard to feed
Dog is being feeding
Dog is playing
3. Beautiful horses are racing
4. Pigs are being fed

Result.
I would like to extract the rows that contain 'dog' and paste it in A1 while also eliminating other rows.

Dog is being feeding
Dog is playing

Appreciate your help.
Thanks!

 

[FastFixFox]

Sorry, quick write and quick test but should work fine for this.

Checks for value entered in input box being present in columns A-Z in all used rows and moves them up accordingly, clears rows where it is not present.

Sub DeleteRowsNotContaining()

Dim Sheet As Worksheet
Dim Count As Integer
Dim WordEntered As String


Set Sheet = ActiveWorkbook.ActiveSheet
Count = 1


WordEntered = InputBox("Word to sort by:")




    For i = 1 To Sheet.UsedRange.Rows.Count
        
            If Not IsError(Application.Match(WordEntered, Sheet.Range("a" & i & ":z" & i), 0)) Then
                
                Sheet.Range("a" & Count & ":z" & Count).Value = Sheet.Range("a" & i & ":z" & i).Value
          
                Count = Count + 1
                    
                    If i > Count Then
                        Sheet.Range("a" & i).EntireRow.Clear
                    End If
                    
            Else
                
                Sheet.Range("a" & i).EntireRow.Clear
                
            End If
            
    Next i


  
End Sub

 

[Somdada]

Thanks FastFixFox for the fast response! Greatly appreciate it.
However, the macro is eliminating the rows containing the word 'Dog'.
Can the macro be altered such that I don't have to enter the word 'dog' in the input box?
Also, instead of pasting the result back to the cell A1, can the extracted rows be on cell B1 without any space blank row between them?