Makro, um unterstrichene Wörter zu finden, friert ein Word

Question

Ich habe ein Makro, das ich verwenden möchte, um alle unterstrichenen Wörter in einem Word-Dokument herauszuziehen und sie irgendwo zu speichern. Ich habe versucht, zu .txt und .xlsx zu speichern, und es friert beide Zeiten ein.

Hier ist mein Code:

Sub addUnderlinedWordsToArray_2() 
Dim thisDoc As Word.Document, rngXe As Word.Range 
Dim aRange As Range 
Dim intRowCount As Integer 
Dim myWords() As String 
Dim i As Long 
Dim bFound As Boolean 

i = 0 

Application.ScreenUpdating = False 

Set thisDoc = ActiveDocument 
Set aRange = thisDoc.Content 
Set rngXe = aRange.Duplicate 
bFound = True 

With aRange.Find 
    ' .ClearFormatting 
' .ClearAllFuzzyOptions 
    .Font.Underline = True 
    .Wrap = wdFindStop 
End With 

Do While bFound 
    bFound = aRange.Find.Execute 
    If bFound Then 
     Set rngXe = aRange.Words(1) 
     'aRange.Select 
     If bFound Then 
      If Len(aRange) > 1 Then 
       If Not aRange.InRange(thisDoc.TablesOfContents(1).Range) Then 
        aRange.MoveEndWhile cset:=Chr(13), Count:=wdBackward 
        ReDim Preserve myWords(i) 
        myWords(i) = aRange.Text 
        i = i + 1 
        aRange.Collapse wdCollapseEnd 
'     Debug.Print "Page: " & aRange.Information(wdActiveEndAdjustedPageNumber) 
       End If 
      End If 
     End If 
    End If 
Loop 

Set aRange = Nothing 
Application.ScreenUpdating = True 
MsgBox ("Done!") 
End Sub 

Ich habe durch sie viel trat, und ich habe nie einen Fehler geworfen bekommen. Es ist funktioniert aber, da ich sehen kann, dass das Array ausgefüllt wird. Mit dem obigen Code wollte ich es zuerst zum Laufen bringen und dann das Array myWords() in ein anderes Sub weiterleiten, das sie zeilenweise in eine .txt-Datei schreibt.

Volle Enthüllung: Ich bin nicht sicher, ob es Fehler in diesem Code oder nicht gibt, aber ich habe auch darüber in CodeReview gefragt, wie ich dachte, der Code funktioniert, konnte nur optimiert werden. Nachdem ich damit gespielt habe, bin ich nicht sicher, ob der Code tatsächlich funktioniert, also frage ich hier. Ich bin mir nicht sicher, was die Regeln für die doppelte Veröffentlichung sind, also lassen Sie mich bitte wissen, ob dies nicht in Ordnung ist, auch hier zu fragen.

Answer 1

Geben Sie eine Einstellung. Ich konnte 30.000 unterstrichene Wörter von insgesamt 140.000 Wörtern in ungefähr 25 Sekunden identifizieren.

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 myDoc.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