Sub Bar()
'
' Bar Macro
'
'
Application.ScreenUpdating = False
Dim i As Long, j As Long, bFnd As Boolean
With ActiveDocument.range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "<[A-Z][! ]@> <[! ]@> <[! ]@> <[! ]@> <[! ]@> <[! ]@>"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
    bFnd = True
    For i = 1 To UBound(Split(.Text, " "))
      If Not Left(Split(.Text, " ")(i), 1) Like "[A-Z]" Then
        bFnd = False
        Exit For
        .End = .Duplicate.Words(i).End
      End If
        .Collapse wdCollapseEnd
    .Find.Execute
    Next
  Do While Selection.Find.Execute
Selection.StartOf Unit:=wdParagraph
Selection.MoveEnd Unit:=wdParagraph
sBigString = sBigString + Selection.Text
Selection.MoveStart Unit:=wdParagraph
Loop
Documents.Add DocumentType:=wdNewBlankDocument
Selection.InsertAfter (sBigString)
End Sub