[文件] 將文字替換成交互參照的VBA

[JieJuen (David)]

軟體:WORD

版本:希望在2007使用

大家好，首先，我建立幾組編號項目

1.
2.      a
3.      b
4.

A.     eee
B.     fff

然後我打一些字
aaabc bcc dddccc eeexxfff

問題：希望有一程式能將文字a替換成交互參照的a 其餘項目類推
說明：此處的交互參照是指  插入/交互參照/編號項目/段落文字

目前理想的演算法：
使用者選取文字後，執行程式開始複製第一個編號項目的交互參照到剪貼簿
然後全部取代選取範圍的文字的a為剪貼簿內容( .Replacement.Text = "^c" )
接著做第二個編號項目，直至結束

卡關處：
1. 目前是在文末插入交互參照後剪下來放入剪貼簿，有無更好的方法?
2. "全部取代"取代後無法按照目的地格式，因此只好逐一搜尋再貼上
3. 編號項目中間有空項目時會錯誤 ON ERROR GOTO xx也沒有用

http://2y.drivehq.com/q/Txt2CrossRef.docm

謝謝! 有點冗長的程式碼與問題!


Option Explicit
Sub Txt2CrossRef()
'

    Dim exeRng As Range
    Dim doRng As Range
    Dim pasteRng As Range
    Dim doFld As Field
    Dim chkFldNm As Integer
    Dim doText As String
    Dim i As Integer

    Set exeRng = Selection.Range
    Set pasteRng = ActiveDocument.Content
    pasteRng.Collapse Direction:=wdCollapseEnd
'    pasteRng.EndKey Unit:=wdStory
    i = 1

    Do While i <=
UBound(ActiveDocument.GetCrossReferenceItems(wdRefTypeNumberedItem))
    Debug.Print
UBound(ActiveDocument.GetCrossReferenceItems(wdRefTypeNumberedItem))

        On Error GoTo NoListInsert
        chkFldNm = ActiveDocument.Fields.Count
        pasteRng.InsertCrossReference ReferenceType:="編號項目",
ReferenceKind:= _
        wdContentText, ReferenceItem:=i, InsertAsHyperlink:=False, _
        IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "

        If chkFldNm = ActiveDocument.Fields.Count Then
            GoTo NoListInsert
        End If
        Set doFld = ActiveDocument.Fields(ActiveDocument.Fields.Count)
        doText = doFld.Result
        doFld.Cut
'        On Error GoTo 0

        Debug.Print doText

        Set doRng = Selection.Range

        Do While doRng.InRange(exeRng)

        doRng.Find.ClearFormatting
        doRng.Find.Replacement.ClearFormatting
        With doRng.Find
            .Text = doText
            .Replacement.Text = "^c"
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchByte = True
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute 'Replace:=wdReplaceAll
        End With
        doRng.Select

        If Selection.InRange(exeRng) Then
            Selection.PasteAndFormat
(wdFormatSurroundingFormattingWithEmphasis)
            Set doRng = ActiveDocument.Range(Start:=Selection.Start,
End:=exeRng.End)
        End If
        Loop
NoListInsert:

    exeRng.Select
    i = i + 1
    Set doFld = Nothing
    Loop

End Sub

--
※ 發信站: 批踢踢實業坊(ptt.cc)
◆ From: 59.115.162.243
※ 編輯: JieJuen         來自: 59.115.162.243       (10/23 04:46)
推 bulldog:Error部分試試 On Error Resume Next?
→ JieJuen:哦~原來RESUME NEXT可以單獨用,放到NoListInsert後可行~