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) > 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: " & 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, b

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.

StackExchange Code Review Q#136225, answer score: 5