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