在Microsoft Word 2010中查找和替换

Question

我有一个Microsoft Word的VBA宏，我正在努力改进。

该宏通常用于大约50,000字的Word文档，该文档分为大约500个部分

宏的目的是突出显示Word文档中的单词/短语，并在每个部分中为该单词/短语的第一次出现插入脚注。

然后，它对下一节重复此操作，直到文档结束。

然后返回到第一节，并在Excel列表中重复下一个单词的过程。

问题是查找和替换操作需要永远才能完成。

Excel列表按降序排序，使最大的短语或单词在前。

我这样做是因为一些短语是较小的单词或短语的复合体。首先定位和更改较大的短语，以便查找和替换不会错误地拾取短语的较小元素。

    Sub Test()
Word.Application.ScreenUpdating = False
Dim xlapp As Object
Dim xlbook As Object
Dim xlsheet As Object
Dim xlrange1 As Object
Dim xlrange2 As Object
Dim myarray As Variant
Dim Findarray As Variant
Dim Replarray As Variant
On Error Resume Next
Set xlapp = GetObject(, "Excel.Application")
If Err Then
 bstartApp = True
 Set xlapp = CreateObject("Excel.Application")
End If
On Error GoTo 0
With xlapp
 Set xlbook = .Workbooks.Open("C:\Users\Documents\test.xlsx")
 Set xlsheet = xlbook.Worksheets(2)
 With xlsheet
 Set xlrange1 = .Range("A1", .Range("A1").End(4))
 Set xlrange2 = .Range("B1", .Range("B1").End(4))
 Findarray = xlrange1.Value
 Replarray = xlrange2.Value
 End With
End With
If bstartApp = True Then
 xlapp.Quit
End If
Set xlapp = Nothing
Set xlbook = Nothing
Set xlsheet = Nothing
Set xlrange1 = Nothing
Set xlrange2 = Nothing
iSectCount = ActiveDocument.Sections.Count
For i = 2 To UBound(Findarray)
For x = 1 To iSectCount
ActiveDocument.Sections(x).Range.Select
Selection.Find.ClearFormatting
 Selection.Find.Font.Color = -587137025
 Selection.Find.Replacement.ClearFormatting
 With Selection.Find
 .Text = Findarray(i, 1)
 .Forward = True
 .Format = True
 .MatchWholeWord = True
 End With
 If Selection.Find.Execute Then
 ActiveDocument.Footnotes.Add Range:=Selection.Range, Text:=Replarray(i, 1)
 End If
 ActiveDocument.Sections(x).Range.Select
Selection.Find.ClearFormatting
 Selection.Find.Font.Color = -587137025
 Selection.Find.Replacement.ClearFormatting
 Selection.Find.Replacement.Font.Color = wdColorBlue
 With Selection.Find
 .Text = Findarray(i, 1)
 .Replacement.Text = Findarray(i, 1)
 .Forward = True
 .Format = True
 .MatchWholeWord = True
 End With
Selection.Find.Execute Replace:=wdReplaceAll
ActiveDocument.Save
 Next x
 Next i
End Sub    

Answer 1

使用VBA时的一些一般原则是：

1. 避免使用selection对象，因为它会大大减慢代码的速度，尤其是在这种情况下，因为每次都必须重新绘制屏幕。关闭ScreenUpdating不会有太大帮助。
2. 每个...next循环通常比使用索引计数器执行得更快。
3. 确保在模块顶部包含选项explicit，以提醒您声明所有变量。在VBE中，通过选择Tools Options Requires Variable Declaration最容易实现这一点，因为这将把它添加到您添加的每个新模块中。

下面的代码从Excel完成后开始替换示例中的代码。考虑到处理500个部分需要190次的迭代次数，它仍然不会很快，但它应该比当前代码执行得更快。

Set doc = ActiveDocument
For i = 2 To UBound(findArray)
    For Each sec In doc.Sections
        Set findRange = sec.Range
        With findRange.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = findArray(i, 1)
            .Forward = True
            .Format = True
            .MatchWholeWord = True
        End With
        If findRange.Find.Execute Then
            ActiveDocument.Footnotes.Add Range:=findRange, Text:=replArray(i, 1)
        End If
        Set findRange = sec.Range
        With findRange.Find
            .Replacement.ClearFormatting
            .Replacement.Font.Color = wdColorBlue
            .Text = findArray(i, 1)
            .Replacement.Text = findArray(i, 1)
            .Forward = True
            .Format = True
            .MatchWholeWord = True
        End With
        findRange.Find.Execute Replace:=wdReplaceAll
        doc.Save
    Next sec
Next i
Application.ScreenUpdating = True