Find/Replace VBA code is not executing properly - vba

Question

For some odd reason, my code does not work in all instances. It does not catch every instance where there is only 1 space after a period. I was wondering if anyone knows why this may be. I went through every line and I can't figure out why it won't work. It's pretty basic of a code.
The goal behind this code:
period with 1 space goes to period with 2 spaces
period with 2 spaces stay the same
any double spaces in the document that do not follow a period are changed to 1 space.
Mr., Mrs., Miss., Ms. only have 1 space after them.
Sub Space_corrections()
' two spaces go to one space entire doc
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
' One space after periods goes to two spaces
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
' Three spaces after periods goes to two spaces
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
' Two spaces after Mr. goes to one space
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "Mr. "
.Replacement.Text = "Mr. "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
' Two spaces after Mrs. goes to one space
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "Mrs. "
.Replacement.Text = "Mrs. "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
' Two spaces after Ms. goes to one space
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "Ms. "
.Replacement.Text = "Ms. "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
' Two spaces after Miss. goes to one space
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "Miss. "
.Replacement.Text = "Miss. "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub```
UPDATE/EDIT:
I changed over to this code, but it does to change all of the instances. I am not sure what the cause is.
There is no special font on them or anything. They are sentences that are contained by a list format, but every other instance that was changed was also contained in a list format.
These are the instances that went unchanged:
**"shipped. According"
"materials. The"**
updated code:
Sub Space_corrections_123()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "(.)( {1,})"
.Replacement.Text = "\1 "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Answer 1

You can simplify the find and replace for the Mr/Mrs/Miss/Ms/Dr/Professor etc by using a wildcard search
.findtext="([rs])(. )"
.replacementText="\1. "
Which will find any word ending in a r or s followed by a point and two spaces and replace with the found character plus point and one space.
You can also do a wildcard search to consolidate the replacement of . by to . two spaces using
.findtext="(.)( {1,})"
.replacementText="\1 "

Answer 2

Try:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Format = False
.Wrap = wdFindContinue
.MatchWildcards = True
.Text = "([ ^s]){2,}"
.Replacement.Text = "\1"
.Execute Replace:=wdReplaceAll
.Text = "(. )"
.Replacement.Text = "\1 "
.Execute Replace:=wdReplaceAll
.Text = "([DM][irs]{1,3}.)[ ]{2,}"
.Replacement.Text = "\1 "
.Execute Replace:=wdReplaceAll
End With
End With
Application.ScreenUpdating = True
End Sub
Note the 'D' in '[DM]'. That allows you to find Dr., & Drs. as well (in case there's more than one). You can delete the 'D' if it's unnecessary.