Seems I hadn't made sufficient provision for what follows the titles. Try:
Code:
Sub Demo()
Application.ScreenUpdating = False
Dim Tbl As Table
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = True
.Text = "^13([!\[])"
.Replacement.Text = "|\1"
.Execute Replace:=wdReplaceAll
.Text = "\]^13"
.Replacement.Text = "^t^&"
.Execute Replace:=wdReplaceAll
End With
Set Tbl = .ConvertToTable(Separator:=wdSeparateByTabs, NumColumns:=2)
With Tbl
.Sort ExcludeHeader:=False, FieldNumber:="Column 1", CaseSensitive:=False, _
SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
.Rows.ConvertToText Separator:=wdSeparateByParagraphs
End With
With .Find
.Text = "|"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
.Text = "^13(\])"
.Replacement.Text = "\1"
.Execute Replace:=wdReplaceAll
.Text = "([!^13])(^13\[)"
.Replacement.Text = "\1^p\2"
.Execute Replace:=wdReplaceAll
End With
While .Characters.Last.Previous.Text = vbCr
.Characters.Last.Previous.Text = vbNullString
Wend
End With
Application.ScreenUpdating = True
End Sub