The simple solution - which also helps stop the descriptors and numbers ending up on separate lines, is to use non-breaking spaces throughout:
Code:
Sub SwapText_SchedulePart()
Application.ScreenUpdating = False
With ActiveDocument.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Wrap = wdFindContinue
.MatchWildcards = True
.Forward = True
.Format = True
.Text = "([Ss]chedule) "
.Replacement.Text = "\1^s"
.Execute Replace:=wdReplaceAll
.Text = "([Pp]art) "
.Replacement.Text = "\1^s"
.Execute Replace:=wdReplaceAll
.Text = "([Ss]chedule*)[, ]@([Pp]art*)([ ;.,])"
.Replacement.Text = "\2 of \1\3"
.Execute Replace:=wdReplaceAll
End With
Application.ScreenUpdating = True
End Sub
You might even find it better for the last F/R expression to use:
Code:
.Text = "[Ss](chedule*)[, ]@[Pp](art*)([ ;.,])"
.Replacement.Text = "P\2 of S\1\3"