Word VBA查找替换处理大文档时速度过慢的优化求助

嗨各位，我最近写了一段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
    
    ' Split content into lines
    lines = Split(fileContent, vbCrLf)
    
    ' Resize array to hold find/replace pairs
    ReDim findAndReplaceList(1 To UBound(lines) + 1, 1 To 2)
    
    ' Populate the find/replace array
    For i = 0 To UBound(lines)
        If Trim(lines(i)) <> "" Then
            parts = Split(lines(i), vbTab)
            If UBound(parts) >= 1 Then
                j = j + 1
                findAndReplaceList(j, 1) = parts(0)
                findAndReplaceList(j, 2) = parts(1)
            End If
        End If
    Next i
    
    ' Resize array to actual number of pairs
    If j > 0 Then
        ReDim Preserve findAndReplaceList(1 To j, 1 To 2)
    Else
        MsgBox "No valid find/replace pairs found in the file.", vbExclamation
        Exit Sub
    End If
    
    ' Sort the array by length of find text (longest first) to prevent partial matches
    For i = 1 To j - 1
        For k = i + 1 To j
            If Len(findAndReplaceList(i, 1)) < Len(findAndReplaceList(k, 1)) Then
                temp = findAndReplaceList(i, :)
                findAndReplaceList(i, :) = findAndReplaceList(k, :)
                findAndReplaceList(k, :) = temp
            End If
        Next k
    Next i
    
    Set doc = ActiveDocument
    Set r = doc.Content
    
    ' The slow part: loop through each pair and do find/replace
    For i = 1 To UBound(findAndReplaceList)
        With r.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = findAndReplaceList(i, 1)
            .Replacement.Text = findAndReplaceList(i, 2)
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchCase = False
            .MatchWholeWord = True
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute Replace:=wdReplaceAll
        End With
    Next i
    
    MsgBox "Journal abbreviation complete!", vbInformation
End Sub

我能确定慢的地方就是最后那个遍历替换对、逐个执行Execute Replace:=wdReplaceAll的循环。是不是每次调用Find都会重新扫描整个文档，导致重复开销？有没有办法一次性处理所有替换，或者用更高效的方式减少文档扫描的次数？

麻烦各位大佬给点优化思路，谢谢啦！

备注：内容来源于stack exchange，提问作者user42026