Consulting

Results 1 to 2 of 2

Thread: Automatic Cross-Referencing

  1. #1
    VBAX Newbie
    Joined
    Mar 2021
    Posts
    6
    Location
    I have multiple headings in a document as a scheme that goes like this: heading 1 is Section 1, heading 2 is 1.1, and heading 3 is 1.1(a). Throughout the document, there are references like, please see Section 2.2(c). Instead of going into the insert cross reference each time and find the heading and select it to make a hyperlinked cross reference, I want to do it automatically. I would like it to do the whole document at once, but so far I can only make a code that does it one by one and you have to select it first. It also doesn't pick up anything with a letter, so it won't catch 2.2(c).

    Do you know how to fix this so it does the letter subheadings as well?


    Sub InsertCrossRef()
    
    
    
    Dim RefList As Variant
    Dim LookUp As String
    Dim Ref As String
    Dim s As Integer, t As Integer
    Dim i As Integer
    
    
    
    
    On Error GoTo ErrExit
    With Selection.Range
    ' discard leading blank spaces
    Do While (Asc(.Text) = 32) And (.End > .Start)
    .MoveStart wdCharacter
    Loop
    ' discard trailing blank spaces, full stops and CRs
    Do While ((Asc(Right(.Text, 1)) = 46) Or _
    (Asc(Right(.Text, 1)) = 32) Or _
    (Asc(Right(.Text, 1)) = 11) Or _
    (Asc(Right(.Text, 1)) = 13)) And _
    (.End > .Start)
    .MoveEnd wdCharacter, -1
    Loop
    
    
    
    
    ErrExit:
    If Len(.Text) = 0 Then
    MsgBox "Please select a reference.", _
    vbExclamation, "Invalid selection"
    Exit Sub
    End If
    
    
    
    
    LookUp = .Text
    End With
    On Error GoTo 0
    
    
    
    
    With ActiveDocument
    ' Use WdRefTypeHeading to retrieve Headings
    RefList = .GetCrossReferenceItems(wdRefTypeNumberedItem)
    For i = UBound(RefList) To 1 Step -1
    Ref = Trim(RefList(i))
    If InStr(1, Ref, LookUp, vbTextCompare) = 1 Then
    s = InStr(2, Ref, " ")
    t = InStr(2, Ref, Chr(9))
    If (s = 0) Or (t = 0) Then
    s = IIf(s > 0, s, t)
    Else
    s = IIf(s < t, s, t)
    End If
    If LookUp = Left(Ref, s - 1) Then Exit For
    End If
    Next i
    
    
    
    
    If i Then
    Selection.InsertCrossReference ReferenceType:="Numbered item", _
    ReferenceKind:=wdNumberFullContext, _
    ReferenceItem:=CStr(i), _
    InsertAsHyperLink:=True, _
    IncludePosition:=False, _
    SeparateNumbers:=False, _
    SeparatorString:=" "
    Else
    MsgBox "A cross reference to """ & LookUp & """ couldn't be set" & vbCr & _
    "because a paragraph with that number couldn't" & vbCr & _
    "be found in the document.", _
    vbInformation, "Invalid cross reference"
    End If
    End With
    End Sub
    Last edited by macropod; 04-06-2021 at 01:51 PM. Reason: New topic split from existing thread

  2. #2
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,294
    Location
    We discussed this previously in VBA to automatically mark cross-reference (vbaexpress.com). Please continue the discussion there. Thread closed.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

Posting Permissions

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