Sub Demo()
Dim SearchTerm As String, i As Long
Dim Rng As Range, Doc As Document, RngOut As Range
 
SearchTerm = InputBox("Enter your search terms")
SearchTerm = LCase(Trim(SearchTerm))
If Len(SearchTerm) = 0 Then Exit Sub
 
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = SearchTerm
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = False
    .Execute
  End With
  If .Find.Found Then
    Set Doc = Documents.Add(Visible:=False)
    Do While .Find.Found
      Set Rng = .Duplicate
      With Rng
        .MoveStartUntil Cset:="^^^^^", Count:=wdBackward
        .MoveEndUntil Cset:="^^^^^", Count:=wdForward
        .Select
        If MsgBox(.Text, vbYesNo, "Copy this block?") = vbYes Then
          .Copy
          With Doc
            .Range.InsertAfter "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^"
            Set RngOut = .Characters.Last
            RngOut.Paste
          End With
        End If
      End With
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
    Doc.Activate
    ActiveWindow.Visible = True
  End If
End With
End Sub