For example:
Sub InsertAutoXRefs()
Application.ScreenUpdating = False
Dim Doc As Document, Para As Paragraph
Dim ListNums As String, StrNum As String
Dim i As Long, j As Long, x As Long
Set Doc = ActiveDocument: ListNums = "|"
With Doc
For Each Para In .Paragraphs
With Para.Range.ListFormat
If .ListString <> "" Then ListNums = ListNums & .ListString & "|"
End With
Next
For i = 1 To UBound(Split(ListNums, "|")) - 1
x = Len(Split(ListNums, "|")(i))
If x > j Then j = x
Next
Do While j > 0
For i = UBound(Split(ListNums, "|")) - 1 To 1 Step -1
StrNum = Split(ListNums, "|")(i): x = Len(StrNum)
If x = j Then
ListNums = Replace(ListNums, "|" & StrNum & "|", "|")
Call MakeAutoXRefs(Doc, StrNum)
End If
Next
j = j - 1
Loop
End With
Application.ScreenUpdating = True
End Sub
Sub MakeAutoXRefs(Doc As Document, StrNum As String)
Dim RefList As Variant, i As Long, j As Long
With Doc
RefList = .GetCrossReferenceItems(wdRefTypeNumberedItem)
For i = 1 To UBound(RefList)
If Split(Trim(RefList(i)), " ")(0) = StrNum Then
j = i: Exit For
End If
Next
If j = 0 Then Exit Sub
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = " " & StrNum
.Replacement.Text = ""
.Format = False
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
End With
Do While .Find.Execute
If .Fields.Count = 0 Then
.Start = .Start + 1
.InsertCrossReference ReferenceType:="Numbered item", _
ReferenceKind:=wdNumberFullContext, ReferenceItem:=j, _
InsertAsHyperlink:=True, IncludePosition:=False, _
SeparateNumbers:=False, SeparatorString:=" "
.End = .End + 1
.End = .Fields(1).Result.End
End If
.Collapse wdCollapseEnd
Loop
End With
End With
End Sub