word自动加交叉引用VBA代码

 

Sub Macro13()

'

' Macro13 Macro

'   宏在   2010-7-26   由   陈挺   录制

'

Dim Ting As Integer

For Ting = 0 To 100

    Selection.Find.ClearFormatting

    With Selection.Find

        .Text = " 所示 "

        .Replacement.Text = ""

        .Forward = True

        .Wrap = wdFindContinue

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchByte = True

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

    End With

     If Not Selection.Find.Execute Then

    Exit Sub

    End If

    Selection.MoveDown Unit:=wdLine, Count:=1

    Selection.HomeKey Unit:=wdLine

   

    Selection.InsertCaption Label:=" 表 ", TitleAutoText:="InsertCaption5", Title _

        :="", Position:=wdCaptionPositionAbove, ExcludeLabel:=0

    Selection.TypeText Text:=" "

    ActiveWindow.ActivePane.VerticalPercentScrolled = 2

    Selection.MoveUp Unit:=wdLine, Count:=1

    Selection.EndKey Unit:=wdLine

    Selection.MoveLeft Unit:=wdCharacter, Count:=3

   

   

    Dim myDialog As Dialog, myRef() As String, myLabel As String

    Dim CurrentPar As Paragraph, myRange As Range, strText() As String

    Dim RefCount As String

    On Error GoTo ExitmySub

   

    Set myRange = Selection.Paragraphs(1).Range

    myRange.SetRange myRange.End + 1, ActiveDocument.Content.End

    With myRange.Find

        .Style = " 题注 "

        If .Execute = False Then Exit Sub

        strText = VBA.Split(myRange.Text, " ")

        myLabel = strText(0)

       

    End With

    myRef() = ActiveDocument.GetCrossReferenceItems(myLabel)  -- 放置断点

    RefCount = CStr(UBound(myRef))

   

   

    Selection.InsertCrossReference ReferenceType:=myLabel, ReferenceKind:=wdOnlyLabelAndNumber, ReferenceItem:=RefCount, InsertAsHyperlink:=True

    Selection.TypeBackspace

    Selection.Font.Size = 12

    Selection.MoveDown Unit:=wdLine, Count:=1

    Selection.HomeKey Unit:=wdLine

   

    Next

ExitmySub:

End Sub

转载于:https://www.cnblogs.com/zxsr20/archive/2012/10/02/2710375.html