Question

我有一个宏，我想用它来取出Word文档中所有带下划线的单词，并将它们保存在某个地方。我已经尝试保存到.txt和.xlsx，它两次冻结。

这是我的代码：

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

我已经经历了很多次，我从来没有被抛出错误。它正在工作，因为我可以看到正在填充的数组。使用上面的代码，我计划首先使它工作，然后将myWords()数组传递到另一个sub，它将只是逐行放入.txt文件。

完全披露：我不确定该代码是否存在错误，但我也在CodeReview中询问了这一点，因为我认为代码有效，可以调整一下。在玩这个之后，我不确定代码是否真的有效，所以我在这里问。我不确定双重发布的规则是什么，所以如果这也不合适，请告诉我。

Answer 1

给它一个机会。在大约25秒内，我能够在总共140,000个单词中识别出30,000个带下划线的单词。

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

宏找到带下划线的单词，冻结Word

1 个答案: