Find and Replace very slow in VBA word

I have written the VBA code below in word to replace Journal titles by their abbreviations. Most of the code works just fine. However, the Find and Replace part of the code is very slow for larger documents. I have tried to find ways to make it faster, such as turning of screen updating, but not succeeded in making it faster. Do you have any advice on how to make it faster? The array of Journal titles and their abbreviations is defined from a tab separated .txt file.

Thanks for any advice!

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

So far, I have tried to turn off screen updating, but that did not make it faster. I suspect there is something in the find and replace operation that I could do to speed it up.

The code got substantially faster when I shortened the find and replace list to about 100 items, and updated the code to only do the find and replace in the selected text in the word document using Set r = Selection.Range