Sub InsertAutoXRefsTest()
'Macropod
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)         'Subscript out of rangee
      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