Try:
Code:
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "<[A-Z][! ]@, [A-Z][! ]@>"
.Replacement.Text = ""
.Forward = False
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
If Len(.Text) > 1 Then
Set Rng = .Duplicate
.MoveEndUntil ",", wdBackward
.Start = .End - 1
.Text = " and"
With Rng
.Collapse wdCollapseStart
Do While .Characters.First.Previous.Previous = ","
.Start = .Start - 3
.Start = .Words.First.Start
If Not .Characters.First Like "[A-Z]" Then
.Collapse wdCollapseEnd
Exit Do
End If
Loop
End With
.Start = Rng.Start
.Collapse wdCollapseStart
.Find.Execute
Else
Exit Do
End If
Loop
End With
Application.ScreenUpdating = True
End Sub