在 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 电子表格的屏幕截图

Word文档截图

Answer 1

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

1. 避免使用Selection 对象，因为它会极大地降低您的代码速度，尤其是在这种情况下，因为每次都必须重新绘制屏幕。关闭 ScreenUpdating 并没有多大帮助。
2. For Each ... Next 循环通常比使用索引计数器执行得更快。
3. 确保在模块顶部包含Option Explicit，以提醒您声明所有变量。这在 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