Thank you so much - I have used your alternative at the end but with a lowercase p and s which now makes it work even better - much appreciated.
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 = "p\2 of s\1\3"
.Execute Replace:=wdReplaceAll
End With
Application.ScreenUpdating = True
End Sub