Find and Replace very slow in Word VBA

I have written working Word VBA code to replace Journal titles by their abbreviations.

The Find and Replace part of the code is very slow for larger documents.

The array of Journal titles and their abbreviations is defined from a tab separated .txt file.

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

I tried turning off screen updating, but that did not make it faster.

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