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