Macro to insert a cross reference based on selection

问题

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.

1. 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.

回答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:-

1. 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.
2. 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.

回答2:

Yes it is totally possible...

But as this is not a code writing service 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...

Perhaps see how far you can get and post back with more specific and focused questions :)

来源：https://stackoverflow.com/questions/47559316/macro-to-insert-a-cross-reference-based-on-selection