Удалить всё, кроме параграфов, которые содержат введённый текст

Sub DeleteParWith()
Dim aDoc As Document, nDoc As Document
Application.ScreenUpdating = False
Set aDoc = ActiveDocument
Dim Pattern As String
Pattern = InputBox("Введите строку")
aDoc.Activate
With Selection
    .HomeKey Unit:=wdStory
    .Find.ClearFormatting
    With .Find
        .Text = Pattern
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
End With
Do
    With Selection
        If Not .Find.Execute Then Exit Do
        .StartOf Unit:=wdParagraph
        .EndOf Unit:=wdParagraph, Extend:=wdExtend
        .Delete
        .EndKey Unit:=wdLine
    End With
Loop
Application.ScreenUpdating = True
End Sub

Option Compare Text
 
Sub KeepParWith()
Dim i As Long, Pattern As String
Pattern = "*" & InputBox("Введите строку") & "*"
Application.ScreenUpdating = False
With ActiveDocument
  For i = .Paragraphs.Count To 1 Step -1
    If Not .Paragraphs(i).Range.Text Like Pattern Then
      .Paragraphs(i).Range.Delete
    End If
  Next
End With
Application.ScreenUpdating = True
End Sub