Word VBA Поиск и замена работает очень медленно, потребляя много ресурсов

Question

У меня есть более 800 страниц документа, созданного программой моделирования. Этот документ состоит в основном из серии пронумерованных предложений (не пронумерованных списков). Может быть до 10 000 пронумерованных строк, которые будут преобразованы в 5000-7000 пронумерованных списков различной длины.

Сценарий VBA для Word (см. Ниже) ищет первый нумерованный абзац, следующий за ненумерованным, а затем просматривает для последнего пронумерованного абзаца перед ненумерованным абзацем, затем преобразует диапазон в нумерованный список. Эта последовательность повторяется до конца документа.

Процедура работает должным образом. Проблема в том, что он потребляет 65-95% процессорного времени, большую часть физической памяти и требует 5-15 часов для запуска. будет приветствоваться.

Образец документа до обработки:

Образец документа после обработки:

VBA Процедура:

    ' Cleanup Numbered Lists
    Sub UpdateNumbering()
        Dim rng0, rng1, rng2 As Range
        Dim sRegEx()
        Dim index As Long
        Dim StoryEnd As Long
        Dim EscCnt As Long
        Dim TotPCnt As Long


        ' Note name of Method being called
        UpdateStatusBar ("UpdateNumbering")
        CalledFrom = LastSubroutineVisited
        LastSubroutineVisited = "UpdateNumbering"

        ' Cleanup [Space}[Tab} variances, Convert to [Tab] Only
        Set rng0 = Selection.Range
        Set rng1 = rng0
        rng0.WholeStory
        rng1.WholeStory
        StoryEnd = rng1.End
        With rng1.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = "\. {1,}^9"
            .Replacement.Text = ".^t"
            .Forward = True
            .Wrap = wdFindStop
            .MatchWildcards = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .Execute Replace:=wdReplaceAll
        End With

        ' Cleanup #.[Space] to #.[Tab]
        With rng1.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = "(^13[0-9]{1,}\.) {1,}"
            .Replacement.Text = "\1^t"
            .Forward = True
            .Wrap = wdFindStop
            .MatchWildcards = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .Execute Replace:=wdReplaceAll
        End With


        ' Define number formats to be cleaned up
        sRegEx = Array("(^13[0-9]{1,2}\.^9)", _
                       "(^13^9[0-9]{1,2}\.^9)")


        ' Loop through each RegEx
        For index = 0 To 1
            ' Status Update
            UpdateStatusBar ("UpdateNumbering: Pass #" & CStr(index + 1))
            LastSubroutineVisited = "UpdateNumbering: Pass #" & CStr(index + 1)


            ' Find Begin of Doc
    '        Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
    '        Selection.Collapse Direction:=wdCollapseStart
            EscCnt = 0
            TotPCnt = ActiveDocument.Paragraphs.Count
            Do
                ' Find First Line of Next Numbered List
                With rng0.Find
                    .ClearFormatting
                    .Text = sRegEx(index)
                    .Forward = True
                    .Wrap = wdFindStop
                    .MatchWildcards = True
                    .MatchCase = False
                    .MatchWholeWord = False
                    .MatchAllWordForms = False
                    .MatchSoundsLike = False
                    .Execute
                    If .Found = False Then Exit Do
                End With

                ' Status Update
                UpdateStatusBar ("UpdateNumbering: Pass #" & CStr(index + 1) & " - " & _
                                 Format(ActiveDocument.Range(0, Selection.Paragraphs(1).Range.End).Paragraphs.Count / _
                                 TotPCnt, "Percent") & " Percent Complete")

                ' Mark beginning of List
                rng0.Select
                Selection.Collapse Direction:=wdCollapseStart
                Selection.MoveDown Unit:=wdParagraph
                Set rng1 = Selection.Range
                rng1.SetRange Start:=rng1.Start + 1, End:=rng1.End

                ' Find and Mark last entry in Numbered List
                Do
                    Selection.MoveDown Unit:=wdParagraph
                    Selection.Expand Unit:=wdParagraph
                    Set rng2 = Selection.Range
                    rng2.SetRange Start:=rng2.Start - 1, End:=rng2.End
                    ' Level 1 Numbering
                    With rng2.Find
                        .ClearFormatting
                        .Text = sRegEx(index)
                        .Forward = True
                        .Wrap = wdFindStop
                        .MatchWildcards = True
                        .MatchCase = False
                        .MatchWholeWord = False
                        .MatchAllWordForms = False
                        .MatchSoundsLike = False
                        .Execute
                        If .Found = False Then Exit Do
                    End With
                    Selection.Collapse Direction:=wdCollapseStart
                Loop
                rng1.SetRange Start:=rng1.Start - 1, End:=rng2.Start

                ' Remove Numbering
                With rng1.Find
                    .ClearFormatting
                    .Replacement.ClearFormatting
                    .Text = "[0-9]{1,2}\.^t{1,}"   'allow for  0 or more tabs
                    .Replacement.Text = ""
                    .Forward = True
                    .Wrap = wdFindStop
                    .MatchWildcards = True
                    .MatchCase = False
                    .MatchWholeWord = False
                    .MatchAllWordForms = False
                    .MatchSoundsLike = False
                    .Execute Replace:=wdReplaceAll
                End With
                rng1.SetRange Start:=rng1.Start + 1, End:=rng1.End

                ' Update Numbered List
                rng1.ListFormat.ApplyListTemplate _
                    ListTemplate:=ListGalleries(wdNumberGallery).ListTemplates(1)
                rng1.End = rng1.End + 1
                rng0.SetRange Start:=rng1.End, End:=StoryEnd
                EscCnt = EscCnt + 1             ' Debug
    '            If EscCnt > 50 Then Exit Do     ' Debug
            Loop
        Next

    LastSubroutineVisited = CalledFrom
    Err_Handler:
       If (Err.Number <> 0) Then
          Call Handle_Error
          Err.Clear
       End If

    End Sub

' Update the Status Bar
Private Sub UpdateStatusBar(status As String)
   ActiveDocument.Application.StatusBar = status
End Sub

' Inform user and break into debug mode.
Private Sub Handle_Error()
   Dim msgbox_Reply As Integer

   msgbox_Reply = MsgBox("An unexpected error has occured:" & vbCrLf & vbCrLf _
                         & "Subroutine: " & LastSubroutineVisited & vbCrLf & vbCrLf _
                         & "Error Number: " & Err.Number & vbCrLf _
                         & "Error Description: " & Err.Description & vbCrLf & vbCrLf _
                         & "VBA will now enter debug mode.", vbCritical + vbOKOnly, "Error")

   ' Turn on screen updating.
   ActiveDocument.Application.ScreenUpdating = True
'   Application.WindowState = wdWindowStateMaximize

   ' Break into debug mode.
   Stop
End Sub

Вот окончательная версия кода благодаря @TechnoDabbler:

' Cleanup Numbered Lists
Sub UpdateNumbering()
    Dim rng0, rng1 As Range
    Dim oRegEx As New RegExp
    Dim oPar As Paragraph
    Dim bNewList As Boolean
    Dim sRegEx As String
    Dim sTemps As MatchCollection
    Dim index1, index2 As Long
    Dim TotPCnt As Long
    Dim tStart As Variant

    tStart = Now()

    ' Note name of Method being called
    UpdateStatusBar ("UpdateNumbering")
    CalledFrom = LastSubroutineVisited
    LastSubroutineVisited = "UpdateNumbering"

    ' Cleanup [Space}[Tab} variances, Convert to [Tab] Only
    Set rng0 = Selection.Range
    Set rng1 = rng0
    With rng1.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "\. {1,}^9"
        .Replacement.Text = ".^t"
        .Forward = True
        .Wrap = wdFindStop
        .MatchWildcards = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .Execute Replace:=wdReplaceAll
    End With

    ' Cleanup #.[Space] to #.[Tab]
    With rng1.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "(^13[0-9]{1,}\.) {1,}"
        .Replacement.Text = "\1^t"
        .Forward = True
        .Wrap = wdFindStop
        .MatchWildcards = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .Execute Replace:=wdReplaceAll
    End With


    ' Define number formats to be cleaned up
    sRegEx = "^\t*[0-9]+\.\t+"


    ' Init Variables
    index2 = 0
    TotPCnt = ActiveDocument.Paragraphs.Count
    With oRegEx
        .Pattern = sRegEx
        .Global = False
    End With
    bNewList = False
    For Each oPar In ActiveDocument.Paragraphs
        ' Status Update
        index2 = index2 + 1
        If index2 Mod 10 = 0 Then
            ActiveDocument.Application.StatusBar = _
                "UpdateNumbering:" & _
                Format(index2 / TotPCnt, "Percent") & " Percent Complete"
        End If
        ' Find First Line of Next Numbered List
        If oRegEx.Test(oPar.Range.Text) Then
            ' Extend the Range of the List and Clean up
            Set rng0 = oPar.Range
            Set sTemps = oRegEx.Execute(oPar.Range.Text)
            index1 = Len(sTemps(0).Value)
            rng0.End = rng0.Start + index1
            rng0.Delete
            If Not bNewList Then
                ' Mark beginning of List
                bNewList = True
                Set rng1 = oPar.Range
            End If
            rng1.End = oPar.Range.End
        ElseIf bNewList Then
            ' Update Numbered List
            rng1.ListFormat.ApplyListTemplate _
                ListTemplate:=ListGalleries(wdNumberGallery).ListTemplates(1)
            bNewList = False
        End If
        DoEvents
    Next oPar
    If bNewList Then
        ' Update Numbered List
        rng1.ListFormat.ApplyListTemplate _
            ListTemplate:=ListGalleries(wdNumberGallery).ListTemplates(1)
    End If

LastSubroutineVisited = CalledFrom
Err_Handler:
   If (Err.Number <> 0) Then
      Call Handle_Error
      Err.Clear
   End If

End Sub

Answer 1

Это может быть одним из решений. Возможно, вам придется настроить шаблон регулярных выражений в зависимости от вашего документа. Производительность кажется разумной:

Option Explicit

Public Sub ConvertDocument()

    Dim vParagraph As Paragraph
    Dim vRegExp As New RegExp

    vRegExp.Pattern = "^[0-9]+.\t"

    Application.ScreenUpdating = False
    For Each vParagraph In ActiveDocument.Paragraphs
        If vRegExp.Test(vParagraph.Range.Text) Then
            vParagraph.Range.ListFormat.ApplyNumberDefault
        End If
        ActiveDocument.UndoClear
        DoEvents
    Next
    Application.ScreenUpdating = True

End Sub

Ниже приведен генератор тестовых данных, который я использовал; измените на l oop, чтобы генерировать больше или меньше тестовых данных.

Public Sub TestDataPopulate()

    Dim vCounter As Long
    Dim vParagraph As Paragraph

    Application.ScreenUpdating = False
    For vCounter = 1 To 50
        Set vParagraph = ActiveDocument.Paragraphs.Add
        vParagraph.Range.Text = "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt " & _
                                "ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco " & vbCrLf & _
                                "Lorem ipsum dolor" & vbCrLf & _
                                vbCrLf & _
                                "1." & vbTab & "Lorem ipsum dolor sit amet" & vbCrLf & _
                                "2." & vbTab & "consectetur adipiscing elit" & vbCrLf & _
                                "3." & vbTab & "sed do eiusmod tempor incididunt" & vbCrLf & _
                                vbCrLf
        ActiveDocument.UndoClear
    Next
    Application.ScreenUpdating = True

End Sub