Copy Underline text from Word and Paste into excel

[macropod]

The following macro runs a Word session so that underlined content in Word documents in the selected folder can be extracted from all documents in that folder.

Sub GetWordData()
'Note: this code requires a reference to the Word object model,
'added via Tools|References in the Excel VBE
Application.ScreenUpdating = False
Dim wdApp As New Word.Application
Dim wdDoc As Word.Document
Dim StrFolder As String, StrFile As String
Dim WkSht As Worksheet, i As Long, j As Long
StrFolder = GetFolder
If StrFolder = "" Then Exit Sub
Set WkSht = ActiveSheet
i = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
StrFile = Dir(StrFolder & "\*.docx", vbNormal)
While StrFile <> ""
  Set wdDoc = wdApp.Documents.Open(Filename:=StrFolder & "\" & StrFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    With .Range
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = ""
        .Replacement.Text = ""
        .Wrap = wdFindStop
        .Forward = True
        .Format = True
        .Font.Underline = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute
      End With
      Do While .Find.Found
        i = i + 1
        WkSht.Cells(i, 1).Value = StrFile
        WkSht.Cells(i, 2).Value = .Text
        If .End = wdDoc.Range.End Then Exit Sub
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
    End With
    .Close SaveChanges:=False
  End With
  StrFile = Dir()
Wend
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function