■

http://q.hatena.ne.jp/1249286196
の質問の回答です。

抽出する場所を別ブックとして、データブックと同じ場所に検索結果.xlsという名前で保存するようにしました。
また、検索文字はインプットボックスで入力できるようにしました。

Sub Macro()
    Dim KeyWord As String
    Dim ws As Worksheet
    Dim wb As Workbook
    Dim r As Range
    Dim ro As Long
    Dim c As Long
    
    KeyWord = InputBox("検索する文字を入力してください")
    
    If KeyWord = "" Then
        Exit Sub
    End If
    
    Set ws = ActiveSheet
    Set wb = Workbooks.Add
    
    c = 1
    For Each r In ws.UsedRange
        If InStr(1, r.Value, KeyWord) > 0 And ro <> r.Row Then
            ro = r.Row
            ws.Rows(ro).Copy (wb.Worksheets(1).Rows(c))
            c = c + 1
        End If
    Next
    
    wb.SaveAs (ThisWorkbook.Path & "\検索結果.xls")
    wb.Close
End Sub