在Microsoft Word 2010中查找和替换

Question

我正在尝试改进Microsoft Word的VBA宏。

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

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

宏观所采取的行动如下：

它计算文档中的部分数量和Excel文件中的单词数量（Excel文件中大约190个单词或短语）

然后，它会在Word文档的第一部分中找到Excel文件中第一个出现的第一个单词或短语。

然后插入该单词或短语的脚注（其文本来自Excel文件中的另一列）

然后更改该部分中该词或短语的所有实例的颜色

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

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

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

Excel列表按降序排序，因此最大的短语或单词首先出现。

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

该文档是分段的，因为我希望每个部分中的第一个单词/短语实例都有一个脚注，其余部分通过更改颜色突出显示。

查找和替换操作发生190,000次（500个部分* 190个字*每个部分2次操作），这意味着在我的计算机上运行需要几天时间。

我已经玩过循环的顺序，并且不知道如何减少运行此代码所需的时间，同时保持我想要实现的输出。

我可以请一些帮助/建议，以便更好地进行这项操作吗？

以下是我正在使用的代码的副本：

    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    

excel spreedsheet的截图

Word文档的屏幕截图

Answer 1

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

1. 避免使用Selection对象，因为它会极大地降低代码速度，尤其是在这种情况下，因为每次都必须重新绘制屏幕。关闭ScreenUpdating将无济于事。
2. For Each ... Next循环通常比使用索引计数器执行得更快。
3. 确保在模块顶部包含Option Explicit，以提醒您声明所有变量。通过选择Tools |，可以在VBE中轻松实现选项|需要变量声明，因为它会将其添加到您添加的每个新模块中。

以下代码将从您完成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