在 VBA Word 中查找和替换非常慢

Question

我用word编写了下面的VBA代码，用缩写来替换期刊标题。大部分代码都可以正常工作。但是，对于较大的文档，代码的查找和替换部分非常慢。我尝试过寻找使其更快的方法，例如关闭屏幕更新，但没有成功地使其更快。您对如何使其更快有什么建议吗？期刊标题及其缩写的数组是从制表符分隔的 .txt 文件中定义的。

感谢您的建议！

Sub JournalAbbreviator2_5()
    Dim findAndReplaceList As Variant
    Dim filePath As String
    Dim fileContent As String
    Dim fileNumber As Integer
    Dim lines() As String
    Dim i As Integer
    Dim parts() As String
    Dim j As Integer
    Dim temp As Variant
    Dim doc As Document
    Dim r As Range
    
    ' Define the path to the text file
    filePath = "..."
    
    ' Open the file and read its content
    fileNumber = FreeFile
    Open filePath For Input As #fileNumber
    fileContent = Input$(LOF(fileNumber), fileNumber)
    Close #fileNumber

    ' Remove BOM if present (e.g., UTF-8 BOM)
    If Left(fileContent, 3) = ChrW(&HFEFF) Then
        fileContent = Mid(fileContent, 4)
    End If

    ' Replace different newline characters
    fileContent = Replace(fileContent, vbCrLf, vbLf)  ' Convert Windows line endings to Unix
    fileContent = Replace(fileContent, vbCr, vbLf)    ' Convert Mac line endings to Unix

    ' Split the content into lines
    lines = Split(fileContent, vbLf)
    
    ' Initialize the findAndReplaceList array
    ReDim findAndReplaceList(LBound(lines) To UBound(lines))

    ' Process each line
    For i = LBound(lines) To UBound(lines)
        ' Split the line into parts using tab as the delimiter
        parts = Split(lines(i), vbTab)
        ' Add the parts to the array if it contains exactly 2 elements
        If UBound(parts) = 1 Then
            findAndReplaceList(i) = Array(parts(0), parts(1))
        End If
    Next i

    ' Sort findAndReplaceList by the length of the full title in descending order
    For i = LBound(findAndReplaceList) To UBound(findAndReplaceList) - 1
        For j = i + 1 To UBound(findAndReplaceList)
            ' Check if both elements are arrays and compare their lengths
            If IsArray(findAndReplaceList(i)) And IsArray(findAndReplaceList(j)) Then
                If Len(findAndReplaceList(i)(0)) < Len(findAndReplaceList(j)(0)) Then
                    ' Swap elements
                    temp = findAndReplaceList(i)
                    findAndReplaceList(i) = findAndReplaceList(j)
                    findAndReplaceList(j) = temp
                End If
            End If
        Next j
    Next i

    ' Confirm continuation
    If MsgBox("Continue with the find and replace operations?", vbYesNo + vbQuestion) = vbNo Then
        Exit Sub
    End If
    
    ' Perform find and replace operations with error handling
    Set doc = ActiveDocument
    Set r = doc.Content
    
    ' Turn off screen updating to speed up the process
    Application.ScreenUpdating = False
    
    ' Perform find and replace operations
    For j = LBound(findAndReplaceList) To UBound(findAndReplaceList)
        If IsArray(findAndReplaceList(j)) Then
            On Error Resume Next ' Ignore errors during find and replace
            With r.Find
                .Text = findAndReplaceList(j)(0)
                .Replacement.Text = findAndReplaceList(j)(1)
                .Forward = True
                .Wrap = wdFindContinue
                .Format = False
                .MatchCase = False
                .MatchWholeWord = True
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
            End With
            r.Find.Execute Replace:=wdReplaceAll
            On Error GoTo 0 ' Resume normal error handling
        End If
    Next j
    
    ' Re-enable screen updating
    Application.ScreenUpdating = True
    
    ' Notify user that the process is complete
    MsgBox "The find and replace process is complete.", vbInformation
End Sub

到目前为止，我已尝试关闭屏幕更新，但这并没有使其变得更快。我怀疑在查找和替换操作中我可以做一些事情来加快速度。

Answer 1

当我将查找和替换列表缩短到大约 100 个项目，并使用

Set r = Selection.Range

更新代码以仅在 Word 文档中的选定文本中进行查找和替换时，代码变得更快