Thanks, I've tried to splice the code but it doesn't work. Grateful for any help.
Code:
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