Sub Demo()
Application.ScreenUpdating = False
Dim RngFnd As Range, RngDel As Range
With Selection.Tables(1)
  Set RngFnd = .Range: Set RngDel = .Range
  RngDel.Collapse wdCollapseStart
  With .Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ""
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Highlight = True
      .Format = True
      .MatchWildcards = False
    End With
    Do While .Find.Execute
      If .InRange(RngFnd) = False Then Exit Do
      If .Cells(1).RowIndex > RngDel.Cells(1).RowIndex Then
        RngDel.End = .Tables(1).Cell(.Cells(1).RowIndex - 1, 1).Range.End
        RngDel.Rows.Delete
      End If
      RngDel.Start = .Tables(1).Rows(.Cells(1).RowIndex).Range.End + 1
      .End = .Cells(1).Range.End
      If .Information(wdAtEndOfRowMarker) = True Then .End = .End + 1
      .Collapse wdCollapseEnd
    Loop
  End With
  If RngDel.Information(wdWithInTable) = True Then
    If RngDel.Cells(1).RowIndex <= .Rows.Count Then
      RngDel.End = .Range.End
      RngDel.Rows.Delete
    End If
  End If
End With
Application.ScreenUpdating = True
End Sub