Take all underlined words, put in Excel column I have a 100+ page Word document, that I would like to extract all of the underlined words from.  I am very familiar with VBA and Excel, but relatively new to Word. I was wondering if this is the best way to do what I'm trying.

I will run this from my Word document:

Sub extractUnderlinedWords()
Dim thisDoc As Word.Document
Application.ScreenUpdating = False
Dim appExcel As Object, oxlWbk As Object
Dim FN      As String
Dim aRange  As Range
Dim intRowCount As Integer
intRowCount = 1

Set thisDoc = ActiveDocument
Set aRange = thisDoc.Range

Set appExcel = CreateObject("Excel.application")
FN = "C:\Users\[blah]\UnderlinedWords.xlsx"

If FileExists(FN) Then
    Set oxlWbk = appExcel.workbooks.Open(fileName:=FN).Sheets("Sheet1")
End If

With aRange.Find
    Do
        .Font.Underline = True
        .Execute
        If .Found Then
            '   aRange.Expand Unit:=wdSentence
            '      aRange.Select
            If Len(aRange) &gt; 1 Then
                If Not aRange.InRange(thisDoc.TablesOfContents(1).Range) Then
                    aRange.MoveEndWhile cset:=Chr(13), Count:=wdBackward
                    '    aRange.Copy
                    oxlWbk.Cells(intRowCount, 1).Value = aRange.Text
                    aRange.Collapse wdCollapseEnd
                    Debug.Print "Page: " &amp; aRange.Information(wdActiveEndAdjustedPageNumber)
                    '    aRange.Select
                    If oxlWbk Is Nothing Then
                        intRowCount = 1
                    End If
                    'oxlWbk.Cells(intRowCount, 1).Value = aRange.Text
                    ' oxlWbk.Paste
                    intRowCount = intRowCount + 1
                End If
            End If
        End If
    Loop While .Found
End With
If Not oxlWbk Is Nothing Then
    appExcel.workbooks(1).Close True
    appExcel.Quit
    Set oxlWbk = Nothing
    Set appExcel = Nothing
End If
Set aRange = Nothing
Application.ScreenUpdating = True
MsgBox ("Done!")
End Sub


This does work, but after about page 14, it hangs up and "freezes" on me.  

Should I instead, add all found words to an Array, then after it's done scanning the Word document, focus on Excel and outputting the parts of array row by row?  I think perhaps what's causing the freeze is the jumping back and forth from Word to Excel.  (Or, could it be that I'm using a Do/While loop?)

Again, the idea is to take all underlined words and put in an Excel sheet for reviewing.
In the Word document


Click on an underlined word
In the Home menu, in the Editing  section, click Select > Select Text with Similar Formatting
Copy
Open Excel and paste


You may need to clean it up in Excel, but you don't need VBA to do this.