Hi all,

I'm trying to extract text with particular character styles into a new
document. I've tried the following code, and it just runs an endless
loop:

Sub CollectCustomTopics()
' highlight parts of speech in a particular color then count the
number of lines in the new document!

Dim NewDoc As Document, MainDoc As Document, r As Range

If Documents.count = 0 Then Exit Sub
Set MainDoc = ActiveDocument
Set NewDoc = Documents.Add
MainDoc.Activate
Selection.HomeKey wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
 .Text = ""
 .Forward = True
 .Wrap = wdFindContinue
 .Format = False
 .Highlight = True

 Do While .Execute
   DoEvents

   Set r = NewDoc.Range
   r.Collapse wdCollapseEnd
   Select Case Selection.Style

       Case "Topic Level 1"

           r.InsertAfter "Topic Level 1"
           'r.ParagraphFormat.LeftIndent = 18

       Case "Topic Level 2"
           r.InsertAfter "Topic Level 2"
       Case "Topic Level 3"
           r.InsertAfter "Topic Level 3"
       Case "Topic Level 4"
           r.InsertAfter "Topic Level 4"
       Case "Topic Level 5"
           r.InsertAfter "Topic Level 5"
       Case "Topic Level 6"
           r.InsertAfter "Topic Level 6"
     End Select

     r.InsertAfter Selection.Range.FormattedText
           If Selection.Characters.Last.Text <> vbCr Then _
             r.InsertAfter vbCr

   Loop
End With
NewDoc.Activate
End Sub