Question

我根据自己的需要改编了other answer。我的更改通过填充的数组查看，并将所选文本与Header文本而不是Header编号以及其他一些小的更改进行匹配。

lambda

我想要实现的是在我的文档中的每个单词上运行此代码：

     Sub InsertCrossRef()
        'thank you stackoverflow:                
       https://stackoverflow.com/questions/47559316/macro-to-insert-a-cross-
       reference-based-on-selection
            Dim RefList As Variant 'list of all available headings and 
            numbered items available
            Dim LookUp As String 'string to be lookedup
            Dim Ref As String 'reference string in which there is to be searched
            Dim s As Integer, t As Integer 'calculated variabels for the string changes
            Dim i As Integer 'looping 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, etc
                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

        ' error protection

           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) = 13 Or InStr(1,                                   Ref, LookUp, vbTextCompare) = 12 Then
                        s = InStr(2, Ref, " ") 'set S = xValue when position 2 returns a Space
                        t = InStr(2, Ref, Chr(9)) 'set T = 1 when position 2 returns a Tab
                        If (s = 0) Or (t = 0) Then
                            s = IIf(s > 0, s, t)
                        Else
                            s = IIf(s < t, s, t)
                        End If

                        If LookUp = Right(Ref, Len(Ref) - s) Then Exit For

                        'If LookUp = Left(Ref, s - 1) Then Exit For
                    End If
                Next i

        ' create the cross reference, add a space when acidently a space was selected
                If i Then

                If Right(Selection.Range, 1) = " " Then

                    Selection.InsertCrossReference ReferenceType:="Numbered item", _
                                                   ReferenceKind:=wdContentText, _
                                                   ReferenceItem:=CStr(i), _
                                                   InsertAsHyperlink:=True, _
                                                   IncludePosition:=False, _
                                                   SeparateNumbers:=False, _
                                                   SeparatorString:=" "
                    Selection.InsertAfter " "

                Else
                    Selection.InsertCrossReference ReferenceType:="Numbered item", _
                                                   ReferenceKind:=wdContentText, _
                                                   ReferenceItem:=CStr(i), _
                                                   InsertAsHyperlink:=True, _
                                                   IncludePosition:=False, _
                                                   SeparateNumbers:=False, _
                                                   SeparatorString:=" "
                End If


                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

我的期望是宏会遍历我的文档中的每个单词，看它是否与任何标题匹配并在上面应用交叉引用maacro。

Answer 1

1。以这种方式使主子程序参数化：

Sub InsertCrossRef(rngWord as Range)
    ...
End Sub

2。接下来，在InsertCrossRef内，您需要识别并更改应指向Word Object（rngWord）的所有引用。你的例子：

With Selection.Range '<< this should be changed into...
With rngWord '<<...this

我可以看到一个或多个其他人以这种方式改变。

3。最后，为每个单词调用它以这种方式完成循环：

For Each sentence In ActiveDocument.StoryRanges
   For Each w In sentence.Words

      InsertCrossRef w

   Next
Next

在Word-File中的每个单词上运行VBA宏

1 个答案: