Replacing text with StoryRange on Word VBA makes it briefly unresponsive

3
votes

I've used the following code to find and replace text on every storyrange, although I'm looking specifically for footers/headers and mainbody.

For Each myStoryRange In ActiveDocument.StoryRanges
    If myStoryRange.StoryType = wdPrimaryFooterStory Then

        myStoryRange.Find.Execute FindText:=footerfindreplace.Item(i).FND, Forward:=True, ReplaceWith:=footerfindreplace.Item(i).replc, Wrap:=wdFindContinue, replace:=wdReplaceAll

    End If
    If myStoryRange.StoryType = wdFirstPageFooterStory Then
        myStoryRange.Find.Execute FindText:=footerfindreplace.Item(i).FND, Forward:=True, ReplaceWith:=footerfindreplace.Item(i).replc, Wrap:=wdFindContinue, replace:=wdReplaceAll
    End If

    If myStoryRange.StoryType = wdEvenPagesFooterStory Then
        myStoryRange.Find.Execute FindText:=footerfindreplace.Item(i).FND, Forward:=True, ReplaceWith:=footerfindreplace.Item(i).replc, Wrap:=wdFindContinue, replace:=wdReplaceAll

    End If

Next myStoryRange

It worked allright for the footers and if the document had only one section. However I have documents with more than one section of course, and I'd rather go trough all the document. So I found a different approach:

With ActiveDocument
  For Each Rng In .StoryRanges
    On Error Resume Next
    With Rng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Format = False
      .Forward = True
      .Wrap = wdFindContinue
      .Text = footerfindreplace.Item(i).FND
      .Replacement.Text = footerfindreplace.Item(i).replc
      .MatchCase = True
      .Execute replace:=wdReplaceAll
    End With
    On Error GoTo 0
  Next
  For Each Sctn In .Sections
    For Each HdFt In Sctn.Headers
      With HdFt
        If .LinkToPrevious = False Then
          With .Range.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Format = False
            .Forward = True
            .Wrap = wdFindContinue
            .Text = footerfindreplace.Item(i).FND
            .Replacement.Text = footerfindreplace.Item(i).replc
            .Execute replace:=wdReplaceAll
          End With
        End If
      End With
    Next
    For Each HdFt In Sctn.Footers
      With HdFt
        If .LinkToPrevious = False Then
          With .Range.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Format = False
            .Forward = True
            .Wrap = wdFindContinue
            .Text = footerfindreplace.Item(i).FND
            .Replacement.Text = footerfindreplace.Item(i).replc
            .Execute replace:=wdReplaceAll
          End With
        End If
      End With
    Next
  Next
    End With

This works perfectly but has something I dislike, the word becomes unresponsive for about 10 seconds, regardless of the document. I also found there are 17 types of storyranges, and maybe that's the reason why it takes so long.

I know at least that with headers and footers (which are 6 of them) I can use the condition .Exists = true or false, to skip them. But that doesn't improve the result a lot.

I only have 5 words for replacement, Why does it become unresponsive? Is there a way to make it smooth?

Thanks for any help.

Update:

Upon reading the comments, I've tried the following with no avail

With ActiveDocument.StoryRanges(1).Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Format = False
      .Forward = True
      .Wrap = wdFindContinue
      .Text = footerfindreplace.Item(i).FND
      .Replacement.Text = footerfindreplace.Item(i).replc
      .MatchCase = True
      .MatchAllWordForms = False
      .MatchWholeWord = False
      .MatchWildcards = False
      End With

  For Each Rng In ActiveDocument.StoryRanges
    On Error Resume Next
    With Rng.Find
    .Text = footerfindreplace.Item(i).FND
      .Replacement.Text = footerfindreplace.Item(i).replc
      .Execute replace:=wdReplaceAll
    End With
    On Error GoTo 0
  Next
  For Each Sctn In ActiveDocument.Sections
    For Each HdFt In Sctn.Headers
      With HdFt
        If .LinkToPrevious = False Then
        If HdFt.Exists = True Then
          With .Range.Find
          .Text = footerfindreplace.Item(i).FND
      .Replacement.Text = footerfindreplace.Item(i).replc
            .Execute replace:=wdReplaceAll
          End With
          End If
        End If
      End With
    Next
    For Each HdFt In Sctn.Footers
      With HdFt
        If .LinkToPrevious = False Then
        If HdFt.Exists = True Then
          With .Range.Find
          .Text = footerfindreplace.Item(i).FND
      .Replacement.Text = footerfindreplace.Item(i).replc
            .Execute replace:=wdReplaceAll
          End With
          End If
        End If
      End With
    Next
  Next

If I dont place 

  .Text = footerfindreplace.Item(i).FND
  .Replacement.Text = footerfindreplace.Item(i).replc

In every loop, it will not replace. Also the update display is already false. Can anyone help?

Update: Recently I tried to search every section inside mystory ranges, hoping to filter out the order..

For Each storyrang In ActiveDocument.StoryRanges
For Each Sctn In storyrang.Sections
For Each rang In Sctn.Ranges
With rang
For ii = 1 To footerfindreplace.count
  Call RngFnd(.Range, footerfindreplace.Item(i).FND, footerfindreplace.Item(i).replc) 'find and replace text in the given range
  Next ii
  End With
  Next
  Next
  Next

The result however remains not good

2
vbatextms-word
Try moving everything out if the loops except the execute command. Find remembers previous settings so if the same values are used for each iteration of the loop they can be set once before the loop starts. – freeflow
You should also turn off display updating before and reinstating after. – freeflow

2 Answers

3
votes

Your code is lacking context - specifically regarding footerfindreplace.Item(i).FND and footerfindreplace.Item(i).replc. You're code is also processing all storyranges (which includes headers & footers), then processing headers & footers again by Section.

If footerfindreplace.Item(i).FND and footerfindreplace.Item(i).replc represent a single call to the document, you might use code like:

Sub Demo()
Application.ScreenUpdating = False
Dim Sctn  As Section, HdFt As HeaderFooter
With ActiveDocument
  Call RngFnd(.Range, footerfindreplace.Item(i).FND, footerfindreplace.Item(i).replc)
  For Each Sctn In .Sections
    For Each HdFt In Sctn.Headers
      With HdFt
        If .LinkToPrevious = False Then
          Call RngFnd(.Range, footerfindreplace.Item(i).FND, footerfindreplace.Item(i).replc)
        End If
      End With
    Next
    For Each HdFt In Sctn.Footers
      With HdFt
        If .LinkToPrevious = False Then
          Call RngFnd(.Range, footerfindreplace(i).FND, footerfindreplace(i).replc)
        End If
      End With
    Next
  Next
End With
Application.ScreenUpdating = True
End Sub

Sub RngFnd(Rng As Range, StrFnd As String, StrRep As String)
With Rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Format = False
  .Forward = True
  .Wrap = wdFindContinue
  .Text = StrFnd
  .Replacement.Text = StrRep
  .MatchCase = True
  .Execute Replace:=wdReplaceAll
End With
End Sub

Alternatively, if you're processing multiple footerfindreplace items, you might use code like:

Sub Demo()
Application.ScreenUpdating = False
Dim Sctn  As Section, HdFt As HeaderFooter
With ActiveDocument
  Call RngFnd(.Range, footerfindreplace)
  For Each Sctn In .Sections
    For Each HdFt In Sctn.Headers
      With HdFt
        If .LinkToPrevious = False Then
          Call RngFnd(.Range, footerfindreplace)
        End If
      End With
    Next
    For Each HdFt In Sctn.Footers
      With HdFt
        If .LinkToPrevious = False Then
          Call RngFnd(.Range, footerfindreplace)
        End If
      End With
    Next
  Next
End With
Application.ScreenUpdating = True
End Sub

Sub RngFnd(Rng As Range, ArrFndRep)
Dim i As Long
With Rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Format = False
  .Forward = True
  .MatchCase = True
  .Wrap = wdFindContinue
  For i = 0 To UBound(ArrFndRep)
    .Text = ArrFndRep(i).FND
    .Replacement.Text = ArrFndRep(i).replc
  .Execute Replace:=wdReplaceAll
  Next
End With
End Sub

In either case, though, it's hardly apparent why you'd be processing something described as footerfindreplace in either the document body or its headers...

1
votes

I'm posting this years later in case it helps others coding for StoryRanges.
I've got a similar issue and the OP's code gave me a start, so this is my Thank you.

The OP wanted to replace arbitrary text in MainTextStory, and in all Headers & Footers.
His original code failed if there was more than a single Section.

The vital element is that Help defines StoryRanges as a Collection of Ranges.
Story Ranges can be chained together by the NextStoryRange property

This code iterates the entire document text just once
The Find Replace is the OP's code, but I've added a For loop for clarity

For Each myStoryRange In ActiveDocument.StoryRanges            
    Do
        For i = lbound(footerfindreplace.Item) to Ubound(footerfindreplace.Item)
            myStoryRange.Find.Execute FindText:=footerfindreplace.Item(i).FND, Forward:=True, ReplaceWith:=footerfindreplace.Item(i).replc, Wrap:=wdFindContinue, Replace:=wdReplaceAll
        next i                
        
        If Not myStoryRange.NextStoryRange Is Nothing Then 
            Set myStoryRange = myStoryRange.NextStoryRange
        End If

    Loop Until myStoryRange.NextStoryRange Is Nothing
Next MyStoryRange

I hope this helps somebody at some time

Spilly