Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range, i As Long
With ActiveDocument
  With .Range
    Set Rng = .Duplicate
    .InsertBefore vbCr
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = "(^13)[0-9]{1,}. (ACA-[0-9]{5})"
      .Replacement.Text = "\1\2"
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
      .MatchWildcards = True
      .Execute Replace:=wdReplaceAll
      .Text = "^13ACA-[0-9]{5}"
      .Replacement.Text = ""
      .Wrap = wdFindStop
      .Execute
    End With
    Do While .Find.Found
      .Start = .Start + 1
      Rng.Start = .End
      With Rng
        With .Find
          .Text = "^13ACA-[0-9]{5}"
          .Replacement.Text = ""
          .Forward = True
          .Wrap = wdFindStop
          .Format = False
          .MatchWildcards = True
          .Execute
        End With
        If .Find.Found Then
          Rng.Start = .Start
        Else
          Rng.Start = ActiveDocument.Range.End
        End If
      End With
      .End = Rng.Start
      .ConvertToTable NumColumns:=1, Format:=wdTableFormatNone, AutoFitBehavior:=wdAutoFitWindow
      .Duplicate.Cells.Merge
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
  While .Tables.Count > 1
    .Tables(1).Range.Characters.Last.Next.Delete
  Wend
  With .Tables(1)
    .Sort
    .ConvertToText
  End With
  With .Range
    With .Find
      .Text = "^13ACA-[0-9]{5}"
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchWildcards = True
      .Execute
    End With
    Do While .Find.Found
      i = i + 1
      .Start = .Start + 1
      .InsertBefore vbCr & i & ". "
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
  .Range.Characters.First.Delete
  .Range.Characters.First.Delete
End With
Application.ScreenUpdating = True
End Sub