Sub FindTrademarks()
Dim oDoc_Source As Document
Dim oDoc_Target As Document
 Dim oRange As Range
Dim n As Long
Dim strAllFound As String
  Application.ScreenUpdating = False
  Set oDoc_Source = ActiveDocument
  Set oDoc_Target = Documents.Add
  With oDoc_Source
    Set oRange = .Range
    With oRange.Find
      .Text = Chr(174)
      While .Execute
        oRange.MoveStart wdWord, -1
        oDoc_Target.Range.InsertAfter oRange & vbCr
        
        oRange.Collapse wdCollapseEnd
      Wend
    End With
  End With
End Sub