Word 2016 VBA. Как ускорить поиск и замену там, где много текстовых фреймов

Question

Я пытаюсь ускорить процедуру поиска / замены Word 2016 VBA. Есть около 150 слов / фраз, которые должны быть заменены. Документы могут быть довольно большими, что не является проблемой, но когда текстовых фреймов много, операция f / r занимает очень много времени.

Я использую подпункт «навигатор» более или менее, как описано вРоббинс, Макси, Хьюитт, Уэст и другие, чтобы пройти через все истории в моем файле Word. https://wordmvp.com/FAQs/Customization/ReplaceAnywhere.htm Эта подпрограмма навигатора проходит через каждый сюжетный диапазон, затем другая подпрограмма выполняет стандартную процедуру поиска / замены VBA для текста в этом диапазоне.

150 терминов поиска и соответствующие термины замены помещаются в двамассивы (FindArray и ReplaceArray). Простая процедура поиска / замены диапазона VBA выполняет операцию для каждого сюжета.

Проблема заключается в том, что при наличии большого количества фигур, содержащих текстовые фреймы, время до завершения может быть длинным, иногда пять минут или более,так как Word рассматривает каждый текстовый фрейм как отдельный диапазон и запускает новую операцию поиска / замены для каждого. Если текстовых фреймов всего несколько, операция завершается быстрее даже для очень больших файлов Word.

Мне пришла в голову идея разархивировать и извлечь часть document.xml из пакета Word OpenXML (файл docx) и выполнитьVBA найти / заменить операцию, а затем снова собрать пакет docx. Так как весь текст основного сюжета, включая все текстовые фреймы, содержится в document.xml, операция поиска / замены должна быть очень быстрой. К сожалению, я не получил это для повторной сборки в docx, так как мне кажется, что я испортил некоторые теги xml.

Может кто-нибудь увидеть что-нибудь, что я мог бы сделать лучше с помощью следующих трех подпрограмм, чтобы сделатьнайти / заменить? Спасибо!

Option Explicit

Public FindArray() As Variant
Public ReplaceArray() As Variant
Public myDocument As Word.Document

Public Sub NavigateStoryRanges()
'See: https://wordmvp.com/FAQs/Customization/ReplaceAnywhere.htm, for how this navigator sub works

    Dim myRange As Range
    Dim oShape As Shape
    Dim lngJunk As Long

    Set myDocument = ActiveDocument

    MakeArrays

    'Bit of weirdness to get Word to not skip headers/footers
    lngJunk = myDocument.Sections(1).Headers(1).Range.StoryType

    Set myRange = myDocument.StoryRanges(1)

    For Each myRange In myDocument.StoryRanges

        Select Case myRange.StoryType
            Case 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11 'only do these stories

                Do
                    ExecuteFindReplace myRange 
                    On Error Resume Next

                    Select Case myRange.StoryType
                        Case 6, 7, 8, 9, 10, 11 'all the headers and footers
                            If myRange.ShapeRange.Count > 0 Then 
                                For Each oShape In myRange.ShapeRange
                                    If oShape.TextFrame.HasText Then
                                        ExecuteFindReplace oShape.TextFrame.TextRange
                                    End If
                                Next
                            End If
                        Case Else
                            'Do Nothing
                    End Select
                    Debug.Print myRange.StoryType
                    Set myRange = myRange.NextStoryRange
                Loop Until myRange Is Nothing
            Case Else
                'Skip footnote/endnote separator stories which we don't need
        End Select
    Next
End Sub

Private Sub ExecuteFindReplace(ByVal ExecRange As Range)
    Dim i As Long

    If ExecRange.StoryLength > 1 Then
        For i = 1 To UBound(FindArray)
            With ExecRange.Find
                .Text = FindArray(i, 1)
                .Replacement.Text = ReplaceArray(i, 1)
                .Forward = True
                .Wrap = wdFindContinue
                .MatchWholeWord = True
                .Execute replace:=wdReplaceAll
            End With
        Next i
    End If

End Sub

Private Sub MakeArrays()

    Dim oExcel As Excel.Application
    Dim oWorkbook As Excel.Workbook
    Dim oSheet As Excel.Worksheet
    Dim strWorkbookName As String 
    Dim LRow As Long

    strWorkbookName = VBA.Environ$("USERPROFILE") & "\PBT\F-R-terms.xlsx"

    Set oExcel = New Excel.Application
    Set oWorkbook = oExcel.Workbooks.Open(strWorkbookName)
    oExcel.Visible = False
    Set oSheet = oWorkbook.Sheets("CleanUp")

    With oSheet
        LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        FindArray = .Range("A1:A" & LRow).Value2
        ReplaceArray = .Range("B1:B" & LRow).Value2
    End With

    Set oSheet = Nothing
    oWorkbook.Close savechanges:=False
    Set oWorkbook = Nothing
    Set oExcel = Nothing

End Sub