repeat Find & Replace until no more ocurrences are found

[and]

Hi,

I want to replace all instances of multiple consecutive spaces in a
document.

When I record a Find & Replace command, 2 spaces are replaced with 1.
And 3 spaces become 2; 4 become 3, etcetera, so multiple spaces still exist.

This is the recorded code from Word XP.

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = " "
.Replacement.Text = " "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

How can I efficiently change the code so it goes on replacing multiple
spaces until only single spaces are left?

Best regards,

ANDy

 

[Greg]

Andy,

Change .Text to " {2,}
Change .MatchWildCards = True

This will search for any occurance of two or more space and replace
with 1 space.

Remember, as written, your code will only effect the story that the IP
is in when you run the macro (i.e. it won't fix the headers if you are
in the main text). Hre is a macro to cover all story ranges. I added
the MatchWildCards line in the SearchAndReplaceInStory Sub which
normally wouldn't be there:

Public Sub FindReplaceWithVBA()

Dim rngstory As Word.Range
Dim FindText As String
Dim Replacement As String
Dim Response As VbMsgBoxResult


FindText = InputBox("Enter the text that you want to find then
replace.", "Batch Replace Anywhere")
If FindText = "" Then
MsgBox "Cancelled by User"
Exit Sub
End If
Tryagain:
Replacement = InputBox("Enter the replacement text.", "Batch
ReplaceAnywhere ")
If Replacement = "" Then
Response = MsgBox("Do you just want to delete the found text?",
vbYesNoCancel)
If Response = vbNo Then
GoTo Tryagain
ElseIf Response = vbCancel Then
MsgBox "Cancelled by User."
Exit Sub
End If
End If
' Fix the skipped blank Header/Footer problem
MakeHFValid
' Iterate through all story types in the current document
For Each rngstory In ActiveDocument.StoryRanges
' Iterate through all linked stories
Do
SearchAndReplaceInStory rngstory, FindText, Replacement
' Get next linked story (if any)
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing
Next
End Sub
Public Sub SearchAndReplaceInStory(ByVal rngstory As Word.Range, _
ByVal strSearch As String, _
ByVal strReplace As String)
ResetFRParameters
'This routine supplied by Peter Hewett
Do Until (rngstory Is Nothing)
With rngstory.Find
..ClearFormatting
..Replacement.ClearFormatting
..Text = strSearch
..Replacement.Text = strReplace
..MatchWildcards = True
..Execute Replace:=wdReplaceAll
End With
Set rngstory = rngstory.NextStoryRange
Loop
End Sub
Public Sub MakeHFValid()
'And this too
Dim lngJunk As Long
' It does not matter whether we access the Headers or Footers property.
' The critical part is accessing the stories range object
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
End Sub
Sub ResetFRParameters()

With Selection.Find
..ClearFormatting
..Replacement.ClearFormatting
..Text = ""
..Replacement.Text = ""
..Forward = True
..Wrap = wdFindContinue
..Format = False
..MatchCase = False
..MatchWholeWord = True
..MatchWildcards = False
..MatchSoundsLike = False
..MatchAllWordForms = False
End With

End Sub

 

[and]

Thanks Greg. Your method worked.

There appeared to be another way to repeat a search until nothing is
found, which I'll reproduce here for anyone who is interested:

With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting

.Text = " "
.Replacement.Text = " "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute
.Execute Replace:=wdReplaceAll
Loop
End With

It took a long time for me to find out that the .Execute IN the While
loop was necessary after the .Execute from the While loop.


Best,
ANDy
--