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, 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
Again, the idea is to take all underlined words and put in an Excel sheet for reviewing.