3
\$\begingroup\$

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 Do/While loop?)

Again, the idea is to take all underlined words and put in an Excel sheet for reviewing.

\$\endgroup\$
  • 1
    \$\begingroup\$ Hello! Please don't make changes to the original post once it has been reviewed, as that invalidates the current answers. Please see our meta side on performing iterative reviews for more information! \$\endgroup\$ – syb0rg Jul 29 '16 at 16:45
  • \$\begingroup\$ @syb0rg - Ah, sorry! I usually hang out in StackOverflow, and know they like to see what efforts OP has made, so I just thought to include more in here, showing what I've kept trying. Appreciate the note though! \$\endgroup\$ – BruceWayne Jul 29 '16 at 16:47
  • 1
    \$\begingroup\$ Around here we usually post a follow-up question linking back to the original instead. \$\endgroup\$ – Mast Jul 29 '16 at 17:07
  • \$\begingroup\$ @syb0rg I don't see how the revised code invalidates user2023861's answer. I think it should be allowed. \$\endgroup\$ – 200_success Jul 29 '16 at 17:31
3
\$\begingroup\$

Give this a shot. I was able to identify 30,000 underlined words out of a total 140,000 words in about 25 seconds. I also posted this on the SO question. This might a more flexible approach if you want to add various criteria to the search.


To provide some more context as to how this works.

This subroutine works by iterating over each StoryRange, e.g. header, footer, etc, and then each word in each StoryRange. From here it checks to see if the word doesn't have the wdUnderlineNone property (the word will have an underline).

I think this is a bit better than the original post as it avoids using redim preserve for each new item being added (this was part of the original code posted) to the array (this is a costly operation). Instead it creates an array large enough to hold each word, then adds underlined words as they are discovered to the array without a resizing and preserve action being necessary.

In addition, adding data to an array will make transferring data to Excel faster as you can write all the data at once by assigning it to a matching sized Range object.

Sub addUnderlinedWordsToArray()
On Error GoTo errhand:
    Dim myWords()       As String
    Dim i               As Long
    Dim myDoc           As Document: Set myDoc = ActiveDocument ' Change as needed
    Dim aRange          As Range: Set aRange = myDoc.Content
    Dim sRanges         As StoryRanges: Set sRanges = myDoc.StoryRanges
    Dim ArrayCounter    As Long: ArrayCounter = 0 ' counter for items added to the array
    Dim Sentence        As Range
    Dim w               As Variant

    Application.ScreenUpdating = False
    ReDim myWords(aRange.Words.Count) ' set a array as large as the
                                      ' number of words in the doc

    For Each Sentence In ActiveDocument.StoryRanges
        For Each w In Sentence.Words
            If w.Font.Underline <> wdUnderlineNone Then
                myWords(ArrayCounter) = w
                ArrayCounter = ArrayCounter + 1
            End If
        Next
    Next

   'Do something with the array here
   'It's not needed to resize the array, just
   'use for i = Lbound(MyWords) to ArrayCounter-1 
   'this will save a redim preserve, alternatively
   'just select up to ArrayCounter-1 if you are moving to an Excel Range

    'Clean up
    Set myDoc = Nothing
    Set aRange = Nothing
    Set sRange = Nothing
    Application.ScreenUpdating = True
    Exit Sub

errhand:
    Application.ScreenUpdating = True
    MsgBox "An unexpected error has occurred." _
         & vbCrLf & "Please note and report the following information." _
         & vbCrLf & "Subroutine Name: addUnderlinedWordsToArray" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
End Sub
\$\endgroup\$
  • \$\begingroup\$ Holy cow - this worked super fast for me too. I will review your comments and such, and let you know if I have any questions. Mainly, what am I doing so wrong in mine that's causing it to crash (hopefully I can tell, by reading through your post). Cheers! \$\endgroup\$ – BruceWayne Jul 29 '16 at 19:07
  • \$\begingroup\$ This looks to be working really nicely - one thing though, that I would need to tweak, is that this selects individual words. Sometimes I have a multi-word underline, which this takes as unique words. For example (bold = underline in Word): "Automobile is a mode of transport." vs. "Automobile - commercial is a mode of transport, but you make money". The macro, as is, will take "Automobile" and "commercial" as separate entries. I would like them to be only one ("Automobile - commercial") - so, when there's an underlined word found, expand range until no longer underlined. \$\endgroup\$ – BruceWayne Aug 1 '16 at 14:40
  • \$\begingroup\$ For that, I'm trying to do something like this, just after the If w.Font.Underline <> wdUnderlineNone Then...Do While w.Font.Underline = True // w.moveEnd unit:=wdWord, count:=1, but that doesn't seem to be working yet. \$\endgroup\$ – BruceWayne Aug 1 '16 at 14:48
5
\$\begingroup\$

In the Word document

  1. Click on an underlined word
  2. In the Home menu, in the Editing section, click Select > Select Text with Similar Formatting
  3. Copy
  4. Open Excel and paste

You may need to clean it up in Excel, but you don't need VBA to do this.

enter image description here

\$\endgroup\$
  • \$\begingroup\$ This can't be right, it's too simple! :P This is great actually. I would just caveat my issue with the fact that there are some underlines that don't get picked up when selecting another underlined word. I assume this is because the technical type of underline, is different. Is there a way to get the "most basic, stripped down" Underline? In the mean time, this is a superb help, as I can just do it twice - once for regular underline, and again for the other type. My only concern now, is that it misses some underline type. I need to be sure it grabs all words, with any underline type. \$\endgroup\$ – BruceWayne Jul 28 '16 at 20:54
  • \$\begingroup\$ Also, do you have any idea how to do this via VBA? I understand you don't need it - but I was curious how it could grab all instances so fast. I recorded a macro, but it literally does nothing when you do "Select Text with similar...". \$\endgroup\$ – BruceWayne Jul 28 '16 at 20:57
  • \$\begingroup\$ @BruceWayne, I don't know a VBA way, sorry. It might not be selecting every instance because maybe font sizes are different, or colors, or bold, etc. You can select-all and set the font-size, font-name, and so on and try again. \$\endgroup\$ – user2023861 Jul 28 '16 at 21:18
  • \$\begingroup\$ Just to comment on this vs. what I marked as answer - This is awesome, I never knew this option was there. The reason I marked the other, is it addresses the VBA issue. With my specific document, it's been worked on by multiple users, so unfortunately the underline isn't always the same technical underline, so I had to do this with maybe 4 types of Similar Formatting. But for real, in any other case, this would have solved my issue, so thanks a ton for your Answer and comments :D \$\endgroup\$ – BruceWayne Aug 9 '16 at 17:47

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.