I want to use VBA to find all the bold text in a document.  When found and
still selected, copy the formatting, apply a character style called WHATEVER,
then paste the copy formatting back on top of the same text.  Once that is
done, Find the next occurance.  I need to do this for Italic, and Underline,
and Plain Text.  

I can't use wdReplaceALL because I need the text still selected so I can
apply the character style.  I can't seem to get this to work.  The macro runs
forever.  When I break, all the bolded text is exactly what I want (the
character style + bold) but nothing else.  One time I got all but the
italics.  

Dim doc As Document
       Dim strFilename As String
       Dim styFilename As Style
       Dim rngToSearch As Range
       Dim rngResult As Range
       Dim f As Font
     
       Set doc = ActiveDocument
   
       'Capture the document name into a variable
       strFilename = Left(doc.Name, Len(doc.Name) - 4)
   
       On Error GoTo ErrorHandler
   
       'Define a character style with no font attributes
       Set styFilename = doc.Styles.Add(Name:=strFilename,
Type:=wdStyleTypeCharacter)
       With styFilename
           With .Font
               .Bold = False
               .Italic = False
               .Underline = wdUnderlineNone
           End With
       End With
   
BeginHere:
      Set rngToSearch = doc.Range
       Set rngResult = rngToSearch.Duplicate
       
       'Make sure there isn't any text currently selected
       If Selection.Type <> wdSelectionIP Then
           Selection.Collapse _
               Direction:=wdCollapseStart
       End If
       
     
       'Look for Bold text
      Do
           With rngResult.Find
               .ClearFormatting
               .Format = True
               .Font.Bold = True
               .Forward = True
               .Wrap = wdFindStop
               .Execute
           End With
   
          If Not rngResult.Find.Found Then Exit Do
           
           Set f = rngResult.Font.Duplicate
           With rngResult
               .Font.Reset
               .Style = styFilename
               .Font = f
               .MoveStart wdParagraph
               .End = rngToSearch.End
           End With
           Set f = Nothing
           Loop Until Not rngResult.Find.Found
   
           'Look for Italic text
           Do
               With rngResult.Find
                   .ClearFormatting
                   .Format = True
                   .Font.Italic = True
                   .Forward = True
                   .Wrap = wdFindStop
                   .Execute
               End With
   
          If Not rngResult.Find.Found Then Exit Do
   
           Set f = rngResult.Font.Duplicate
           With rngResult
               .Font.Reset
               .Style = styFilename
               .Font = f
               .MoveStart wdParagraph
              .End = rngToSearch.End
           End With
           Set f = Nothing
           Loop Until Not rngResult.Find.Found
   
       'Look for underline text
       Do
           With rngResult.Find
               .ClearFormatting
               .Format = True
               .Font.Underline = wdUnderlineSingle
               .Forward = True
               .Wrap = wdFindStop
               .Execute
           End With
   
       If Not rngResult.Find.Found Then Exit Do
   
       Set f = rngResult.Font.Duplicate
       With rngResult
           .Font.Reset
           .Style = styFilename
           .Font = f
           .MoveStart wdWord
           .End = rngToSearch.End
       End With
       Set f = Nothing
       Loop Until Not rngResult.Find.Found
   
   
       'Look for plain text
       Do
       With rngResult.Find
           .ClearFormatting
           .Format = True
           .Font.Italic = False
           .Font.Bold = False
           .Font.Underline = wdUnderlineNone
           .Forward = True
           .Wrap = wdFindStop
           .Execute
       End With
   
       If Not rngResult.Find.Found Then Exit Do
   
       Set f = rngResult.Font.Duplicate
       With rngResult
           .Font.Reset
           .Style = styFilename
           .Font = f
           .MoveStart wdWord
           .End = rngToSearch.End
       End With
       Set f = Nothing
       Loop Until Not rngResult.Find.Found
       
   Else
        'If Response = vbNo
       MsgBox ("Document will not be changed")
       Exit Sub
   
   End If
       Application.StatusBar = ""
   
ErrorHandler:
   Select Case Err.Number
       'Style name already exists
       Case 5173
           Set styFilename = doc.Styles(strFilename)
           GoTo BeginHere
   End Select
   
End Sub

Thanks!

Caren