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.
Code:
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