Sub TheNewMagicTimeSaver()
  Dim oDoc As Document
  Dim oRng As Range
  Dim strKeyWord As String
  strKeyWord = InputBox("What are you looking for?")
  If strKeyWord = "" Then GoTo lbl_Exit
  Set oRng = ActiveDocument.Range
  Set oDoc = Documents.Add
  With oRng.Find
    Do While .Execute(FindText:=strKeyWord, MatchCase:=False, MatchWholeWord:=True)
      oDoc.Range.InsertAfter oRng.Paragraphs(1).Range.FormattedText
      oDoc.Range.InsertParagraphAfter
      oRng.Paragraphs(1).Range.Delete
      oRng.Collapse 0
    Loop
  End With
  oDoc.Range.ParagraphFormat.SpaceBefore = 0
  oDoc.Range.ParagraphFormat.SpaceAfter = 0
lbl_Exit:
  Exit Sub
End Sub

Sub SortParasBySize()
  Dim aRng As Range, aTable As Table, aRow As Row
  ActiveWindow.View = wdNormalView
  With ActiveDocument.Range.Find  'Do Find and Replace for separators
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "^p"
    .Replacement.Text = "zx"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute Replace:=wdReplaceAll
    .Text = "zxzx"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    ActiveDocument.Range.ConvertToTable Separator:=wdSeparateByParagraphs, NumColumns:=1
    .Text = "zx"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
  End With
  Set aTable = ActiveDocument.Tables(1)
  aTable.Columns.Add BeforeColumn:=aTable.Columns(1)
  For Each aRow In aTable.Rows
    aRow.Cells(1).Range.Text = Len(aRow.Cells(2).Range.Text)
  Next aRow
  aTable.Rows.Add BeforeRow:=aTable.Rows(1)
  aTable.SortDescending
  aTable.Columns(1).Delete
  aTable.Columns.Add    'insert empty column to reinstate extra paras between sections
  aTable.Rows(1).Delete
  aTable.ConvertToText Separator:=wdSeparateByParagraphs
End Sub