CODEWITHSUNDEEP
vbams-word
Eric
Eric

Reputation: 2849

Word runs out of memory when running macro on 27 page document

This post is crossposted on the Microsoft Answers forum.

My macro below is used to secure the word document in question. When it is run on smaller documents (4-10 pages) it works fine, but we have a much larger 27 page document (6000 words) that seems to suck up all the memory! I run it and word ends up freezing on me.

Here is a link to a OneDrive reproducible example: https://1drv.ms/w/s!AgPO3BotYSt7iHvafHts2HyF2OjB?e=HSOI57

Not sure if the formatting holds when accessed via OneDrive, but the checkboxes show an X when clicked.

The 'Description of how you will meet the recommendation' is followed by a text field so the user can input text. Same deal with 'Responsible team' and 'Reasoning for why you disagree:'

After the macro runs, the entire document should be locked down except for the text that is red along with the formatting described above.

Is there anyway to adapt the macro to save some memory allowing it to run when used on larger files?

Here is the macro:

Sub Lock_Teammate_DraftReports_mp()

Selection.HomeKey wdStory

Selection.Find.ClearFormatting

Selection.Find.Font.ColorIndex = wdRed

With Selection.Find

    Do While .Execute(FindText:="", Forward:=True, MatchWildcards:=False, Wrap:=wdFindStop) = True

        Selection.Editors.Add wdEditorEveryone

        Selection.Collapse wdCollapseEnd

    Loop

End With

ActiveDocument.Protect Password:="example123", NoReset:=False, Type:=wdAllowOnlyReading, 
UseIRM:=False, EnforceStyleLock:=False

End Sub

Upvotes: 0

Views: 202

Answers (1)

macropod
macropod

Reputation: 13505

Your problem is most likely related to all the selecting your code is doing, which is both inefficient and liable to causing lots of scrolling and screen flicker. Try:

Sub Lock_Teammate_DraftReports_mp()
Application.ScreenUpdating = False
Dim i As Long
With ActiveDocument
  With .Range
    With .Find
      .ClearFormatting
      .Font.ColorIndex = wdRed
      .Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .MatchWildcards = False
    End With
    Do While .Find.Execute = True
      i = i + 1
      If .Information(wdWithInTable) = True Then
        If .Rows(1).Range.Font.ColorIndex = wdRed Then .End = .Rows(1).Range.End
        If .End = .Cells(1).Range.End - 1 Then .End = .Cells(1).Range.End
        If .Information(wdAtEndOfRowMarker) = True Then .End = .End + 1
      End If
      .Editors.Add wdEditorEveryone
      If .End = ActiveDocument.Range.End Then Exit Do
      .Collapse wdCollapseEnd
      If i Mod 100 = 0 Then DoEvents
    Loop
  End With
  .Protect Password:="example123", NoReset:=False, Type:=wdAllowOnlyReading, UseIRM:=False, EnforceStyleLock:=False
End With
Application.ScreenUpdating = True
End Sub

Upvotes: 2

Related Questions