Sub for replacement: how to get feeback

Hello guys,

I searched the Internet in the past and I found the following piece of code.

Sub FindAndReplaceFirstStoryOfEachType(OldText As String, NewText As String)
Dim rngStory As Range
  
  For Each rngStory In ActiveDocument.StoryRanges
    With rngStory.Find
      .Text = OldText
      .Replacement.Text = NewText
      .Wrap = wdFindContinue
      .Execute Replace:=wdReplaceAll
    End With
  Next rngStory
End Sub

I do not understand this Range thing (despite my experience in VBA in Excel), however this code does work.

I need an upgrade to that code, to convert the Sub (the procedure) into a Function that would return the number of replacements.

This code has proved to be excellent in replacing two consecutive spaces with one but ... ... here comes the big Bee Yu Tee. What about having three consecutive spaces or four?

I could make a loop and run it many times e.g. 12 times. It would be rather unlikely to have more than 12 consecutive spaces in a document. But that sounds stupid and also increases the time required.


If I could get the number of replacement I could run it in a repeat-until loop and run it until the number of replacements becomes zero.

Any idea?

Originally Posted by Kaper

But then thought that looping inside each story will be quicker - so try also on a large document this possibly faster version:

Sub FindAndReplaceAllOccurences_Quick(OldText As String, NewText As String)
Dim rngStory As Range, replaceresult As Boolean
For Each rngStory In ActiveDocument.StoryRanges
  Do
    replaceresult = False
    With rngStory.Find
      .Text = OldText
      .Replacement.Text = NewText
      .Wrap = wdFindContinue
      replaceresult = replaceresult Or .Execute(Replace:=wdReplaceAll)
    End With
  Loop While replaceresult
Next rngStory
End Sub

It works, thank you very much.

Originally Posted by macropod

Try:

Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range, i As Long
For Each Rng In ActiveDocument.StoryRanges
  With Rng
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = "[ ^s]{2,}"
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchWildcards = True
      .Execute
    End With
    Do While .Find.Found = True
      i = i + 1
      .Text = .Characters.First.Text
      .Collapse (wdCollapseEnd)
      .Find.Execute
    Loop
  End With
Next
Application.ScreenUpdating = True
MsgBox i & " replacements made."
End Sub

Note that the above code processes both ordinary spaces and non-breaking spaces. However many spaces are replaced at a given location are treated as a single replacement.

I got an erroe message.


Run-time error '5560';

The Find What text contains a Pattern Match expression which is not valid.

PS: thanks for your help anyway.

Hello again,

I have another question.

The code includes the following structure.

For Each Rng In ActiveDocument.StoryRanges
          With Rng
   
          End With

I suppose that a word document consists of ... Stories? Is it right?

The code above passes through all Stories and does the replacement.

Is it possible to alter the code? Insted of doing replacements across the whole document to do them to a part of the document I have selected.


Is anything like the following?

With Selection
   
      End With

Yeeaaaaah!!!

This is what I needed. You see, I have a MS Word document in which I copy every day's reports (three per day). Each file has a full year's report. EVery time I run my code it passes through the whole document. I just need to have it done for the last days, not the all days.

Thanks buddy.

I had thought of that but I rejected the idea. It seemed a little bit counter productive.

macropod,

thanks for your code.

I worked on your code and the first work was successful. I had to alter the code a little in order to fit my needs (although further work is required).

Sub Demo(OldText As String, NewText As String)’ORIGINAL CODE: Sub Demo()
    Application.ScreenUpdating = False
    Dim Rng As Range, i As Long
    With Selection
         Set Rng = .Range
         With .Range
              With .Find
                   .ClearFormatting
                   .Replacement.ClearFormatting
                   .Text = OldText ’ORIGINAL CODE:      .Text = "[ ^s]{2,}"
                   .Replacement.Text = NewText’ORIGINAL CODE:       .Replacement.Text = ""
                   .Forward = True
                   .Wrap = wdFindStop
                   .Format = False
                   .MatchWildcards = True
                   .Execute
              End With
              Do While .Find.Found = True
                 If .InRange(Rng) = False Then Exit Do
                 i = i + 1
                 .Text = NewText
                 .Collapse (wdCollapseEnd)
                 .Find.Execute
                 Loop
         End With
    End With
    Application.ScreenUpdating = True
    ‘MsgBox i & " replacements made."‘ORIGINAL CODE: MsgBox i & " replacements made."
End Sub

One question, what is this "Application.ScreenUpdating" thing?