Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, Str As String
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "\(*\)"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .MatchSoundsLike = False
    .Execute
  End With
  Do While .Find.Found
    i = i + 1
    Str = Str & " " & .Text
    .Find.Execute
  Loop
  .Start = ActiveDocument.Range.Start
  .End = ActiveDocument.Range.End
  .Find.Execute Replace:=wdReplaceAll
  .InsertAfter vbCr
  .Paragraphs.Last.Style = wdStyleNormal
  Str = Replace(Trim(Str), ") (", Chr(11))
  Str = Mid(Str, 2, Len(Str) - 2)
  .InsertAfter Str
End With
Application.ScreenUpdating = True
MsgBox i & " records processed."
End Sub