Consulting

Results 1 to 8 of 8

Thread: VBA Manual to Auto Cross References

  1. #1

    VBA Manual to Auto Cross References

    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

  2. #2
    Moderator VBAX Guru Aussiebear's Avatar
    Joined
    Dec 2005
    Location
    Queensland
    Posts
    4,236
    Location
    @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.
    Remember To Do the Following....
    Use tags when posting code to the thread,
    Mark your thread as Solved if satisfied by using the Thread Tools options.
    If posting the same issue to another forum please show the link

  3. #3
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,407
    Location
    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.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  4. #4

    VBA Manual to Automatic Cross Reference

    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)
    Attached Images Attached Images

  5. #5
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,407
    Location
    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'...
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  6. #6
    VBAX Regular
    Joined
    Jul 2012
    Posts
    29
    Location
    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
    Attached Files Attached Files

  7. #7
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,407
    Location
    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.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •