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
      .Forward = True
      .Format = False
      .MatchWildcards = True
      .Text = "^13Reference#[0-9]{4}"
      .Replacement.Text = ""
      .Wrap = wdFindStop
      .Execute
    End With
    Do While .Find.Found
      .Start = .Start + 1
      Rng.Start = .End
      With Rng
        With .Find
          .Text = "^13Reference#[0-9]{4}"
          .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
  .Range.Characters.First.Delete
  .Range.Characters.First.Delete
End With
Application.ScreenUpdating = True
End Sub

    For i = .Rows.Count To 2 Step -1
      If .Rows(i).Range.Text = .Rows(i - 1).Range.Text Then .Rows(i).Delete
    Next