VBA Manual to Auto Cross References

[Shelley_Lou]

Hi Macropod - while searching the internet for a related topic on cross references I came across a post on this forum started back in 2021 in which you supplied the code below - unfortunately I was unable to add a reply to that post as it was marked as resolved and generated an error when trying to add my query, so have created a new thread. I apologise if this is not the correct process. I just wanted to ask a couple of questions if possible.

Firstly in relation to that post, I have a similar issue whereby my house style document has Heading 5 as (a) so if any references are for example, clause 1.1.1.1(a) would it be possible to tell the code to skip the cross reference for any levels that are followed by (a), (b) etc. and instead just highlight them, so I know I need to come back to that reference and cross reference manually.

My second query is in my house style documents the main body uses Heading 1-7 and the schedules use Schedule Level 1-7 - at the moment the code only picks up the Heading styles - is there something I could add to the code for it to know what style it should be cross referencing.

Many thanks

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 = False
    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

[Aussiebear]

@Shelley_Lou, the process you followed is correct. We prefer that rather than post to older threads, that you in fact start a new one in which you can refer to the old thread if desired.

[macropod]

Try:

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
Options.DefaultHighlightColorIndex = wdYellow
Set Doc = ActiveDocument: ListNums = "|"
With Doc
  For Each Para In .Paragraphs
    With Para.Range.ListFormat
      If .ListString <> "" Then
        If InStr(ListNums, "|" & .ListString & "|") = 0 Then ListNums = ListNums & .ListString & "|"
      End If
    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
  If Left(StrNum, 1) = "(" Then
    With .Range.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = Trim(StrNum)
      .Replacement.Text = "^&"
      .Replacement.Highlight = True
      .Format = True
      .Forward = True
      .Wrap = wdFindContinue
      .MatchCase = True
      .Execute Replace:=wdReplaceAll
    End With
  Else
    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 = False
      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 If
End With
End Sub

cross-references like (a), (b), (ii), etc. will be highlighted in yellow.

[Shelley_Lou]

Hi Macropod, many thanks for updating the code which I've run on a document today - I am getting a bug in the InsertAutoXRefs code - also it doesn't seem to be picking up any clause 1 headings (Heading 1) so I've had to manually update these.

StrNum = Split(ListNums, "|")(i): x = Len(StrNum)

[macropod]

Without access to the document on which you say the error occurs, it is difficult to say what the error on that line might result from. I ran the code on your 'Before' document at MS Office forums (https://www.msofficeforums.com/169070-post20.html), and it worked fine with that.

If your current document is anything like your 'Before' document, the simple reason the '12' in 'clause 12' isn't cross-referenced is that the corresponding Heading 1 list level number is '12.', not '12'. Even if that were not the case, auto cross-referencing just any old '12' would be unreliable at best. Consider, for example, '12 July' and '10/12/2022'...

[jec1]

Hi Macropod

I get the same error in the original code which I wish to use. I don't want the second code where it highlights in yellow. Attached a test document I used.

Thank you.

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)     'Subscript out of range Runtime error 9
      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 = False
    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

[macropod]

The original code won't work with your document because of the repeated (a), (b), (c) and (i), (ii), (iii) etc. list level numbers. You'd need to use the updated code without the With .Range.Find ... End With block that does the highlighting.

[Shelley_Lou]

Hi Macropod, I've now got the code working for the highlight, many thanks for your help with this.