Macro to insert a cross reference based on selection - vba

Question

I currently work for a company which uses a set house-style for its documents. This includes multi-levelled numbered headings built in to our Word template. I.e.
Heading 1
1.1 Heading 2
1.1.1 Heading 3
etc...
A large part of our current task involves adding in cross references to other parts in the document. This can be quite time consuming when the doc runs to several hundred pages with around 10 references on each page.
What I was wondering was if a macro could be set up to add a x-ref based on whatever is highlighted by the cursor. I.e. if you had a sentence that read "please refer to clause 3.2" you could highlight the "3.2" part, run the macro and have the x-ref linked to heading 3.2 be inserted.
Not sure if this is even possible but would be grateful for any advice.

Answer 1

This code will - conditionally - do what you want.
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
Here are the conditions:-
There are "Numbered Items" and "Headings" in a document. You asked for Headings. I did Numbered Items because I don't have that style on my PC. However, on my PC "Headings" are numbered items. If the code doesn't work on your documents, exchange wdRefTypeNumberedItem for wdRefTypeHeading at the marked line in the code.
I presumed a numbering format like "1" "1.1", "1.1.1". If you have anything different, perhaps "1." "1.1.", "1.1.1.", the code will need to be tweaked. The key points are that the code will look for either a space or a tab following the number. If it is followed by a period or closing bracket or a dash it won't work. Also, if you happen to select "1.2." (with the final full stop) in the text the code will ignore the full stop and look for a reference "1.2". Note that the code is insensitive to casual mistakes in the selection. It will remove any leading or trailing spaces as well as accidentally included carriage returns or paragraph marks - and full stops.
The code will replace the selection you make with its own (identical) text. This may cause existing formatting to change. In fact the inserted Reference Field takes the text from the target. I didn't quite figure out which format it applies, the target's or the one being replaced. I didn't deal with this problem, if it is one.
Please take a look at the properties of the cross reference the code inserts. You will see that InsertAsHyperlink is True. You can set it to False, if you prefer. IncludePosition is False. If you set this property to True you would see "above" or "below" added to the number the code replaces.

Answer 2

Yes it is totally possible...
I'll give you (an example of) the key elements:
' Check if a reference exists
If instr(lcase(selection.Sentences(1).Text), "refer to clause") then
' Figure out the reference number...
(see here: https://stackoverflow.com/questions/15369485/how-to-extract-groups-of-numbers-from-a-string-in-vba)
' Get a list of available references
refList = ActiveDocument.GetCrossReferenceItems(wdRefTypeNumberedItem)
' Add the reference
selection.InsertCrossReference(wdRefTypeNumberedItem ,wdNumberFullContext, xxxxxx...