宏查找加下劃線的單詞，凍結單詞

我有一個宏，我想用它來提取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()數組傳遞到另一個子文件中，它們將逐行放入一個.txt文件中。

完全披露：我不確定是否在該代碼中存在錯誤，但我也在CodeReview中詢問過這個問題，因爲我認爲代碼可行，只是可以調整。玩完這個之後，我不確定代碼是否真正起作用，所以我在這裏問。我不確定雙倍發佈的規則是什麼，所以請讓我知道這是不是也可以問這裏。

來源

2016-07-29 BruceWayne

，直到它停止凍結刪除'Application.ScreenUpdating = FALSE'所以你可以看到發生了什麼或什麼對話框彈出 – dbmitch

什麼，當你說。」我試圖保存到.txt和你的意思做。 xlsx「 - 你的代碼在哪裏？ – dbmitch

除上述建議之外，請嘗試在僅包含幾個帶下劃線的單詞的新文檔上運行此代碼，以查看是否獲得相同的凍結。然後你可以通過整個事情來看看掛起的位置。 –

給這個鏡頭。在大約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

來源

2016-07-29 17:38:46

宏查找加下劃線的單詞，凍結單詞

回答

相關問題