使用高效的VBA宏從檔案中洗掉重復的單詞

我有這個宏，可以將每個單詞與其他單詞進行比較，如果是，則檢查它是否重復，然后將其洗掉，但是它對于 1 到 4 頁的效果非常好，最多 5 分鐘。但是對于 50 或 100 頁的檔案，我花了十年的時間來運行它。

我需要修改或一個新的想法，用更高效的代碼和更少的時間來比較和洗掉重復項。我應該怎么做？

Sub Delete_Duplicates()
    '***********'
    'By
    'MBA
    '***********'
    Dim AD As Range
    Dim F As Range
    Dim i As Long
    
    Set AD = ActiveDocument.Range
    Z = AD.Words.Count
    y = 1
    For i = Z To 1 Step -1
        y = y   1
        
        Set F = AD.Words(i)
        
        On Error Resume Next
        Set s = AD.Words(i - 1)
        If Trim(AD.Words(i - 1)) = "," Then Set s = AD.Words(i - 2): Set c = AD.Words(i - 1)
        If Err.Number > 0 Then Exit Sub
            
        If Not F.Text = Chr(13) And UCase(Trim(F.Text)) = UCase(Trim(s.Text)) Then
                F.Text = ""
            If Not c Is Nothing Then c.Text = " ": Set c = Nothing
        End If
            If Not c Is Nothing Then Set c = Nothing
    
    On Error Resume Next
    Call ProgressBar.Progress(y / Z * 100, True) '<<-- Progress Bar
    On Error GoTo 0
    
    Next
    Beep
End Sub

之前/之后

uj5u.com熱心網友回復：

這只是概念，但嘗試準備檔案中所有單詞的串列，并在存在時替換雙或三單詞。

Private Sub DeleteDuplicate()
    
    Dim wholeTxt As String
    
    Dim w As Range
    Dim col As New Collection
    Dim c
    
    For Each w In ActiveDocument.Words
        AddUniqueItem col, Trim(w.Text)
    Next w

    wholeTxt = ActiveDocument.Range.Text
    
    For Each c In col
        
        'add case with ","
        'maybe one letter word should be forbidden, or add extra boundary
        If InStr(1, wholeTxt, c & " " & c, vbBinaryCompare) <> 0 Then
            'start of doc
            Selection.HomeKey wdStory
            
            'here should be all stuff to prepare replacement
            '(...)
            Selection.Find.Execute Findtext:=c & " " & c, ReplaceWith:=c
            wholeTxt = ActiveDocument.Range.Text
        End If
    Next c
    
    Set col = Nothing
End Sub
Private Sub AddUniqueItem(ByRef col As Collection, ByVal itemValAndKey As String)
    Dim s As String
    On Error Resume Next
    s = col(itemValAndKey)
    If Err.Number <> 0 Then
        col.Add itemValAndKey, itemValAndKey
        Err.Clear
    End If
    On Error GoTo 0
End Sub

uj5u.com熱心網友回復：

假設整個檔案是純文本，我們可以分配整個檔案的文本并使用Split它來將其轉換為單詞陣列。

由于它在陣列中，因此與訪問Words集合相比，處理它們會更快。

這就是我能想到的，但也許有更好的方法來做到這一點？下面的示例使用 Regex 搜索并替換所有匹配的重復項：

Option Explicit

Sub Delete_Duplicate()
    Const maxWord As Long = 2 'Change this to increase the max amount of words should be used to match as a phrase.
    
    Dim fullTxt As String
    fullTxt = ActiveDocument.Range.Text
    
    Dim txtArr() As String
    txtArr = Split(fullTxt, " ")
    
    Dim regex As RegExp
    Set regex = New RegExp
    regex.Global = True
    regex.IgnoreCase = True
    
    Dim outputTxt As String
    outputTxt = fullTxt
    
    Dim n As Long
    Dim i As Long
    
    For i = UBound(txtArr) To 0 Step -1
        Dim matchWord As String
        
        matchWord = vbNullString
        For n = 0 To maxWord - 1
            If (i - n) < 0 Then Exit For
            
            matchWord = txtArr(i - n) & " " & matchWord
            matchWord = Trim$(Replace(matchWord, vbCr, vbNullString))
        
            regex.Pattern = matchWord & "[, ]{0,}" & matchWord
            If regex.test(outputTxt) Then
                outputTxt = regex.Replace(outputTxt, matchWord)
            End If
        Next n
    Next i
    Set regex = Nothing

    Application.UndoRecord.StartCustomRecord "Delete Duplicates"
    ActiveDocument.Range.Text = outputTxt
    Application.UndoRecord.EndCustomRecord
End Sub

標籤：vba 表现 时间 ms-word 重复

上一篇：WordVBA：確定左右表邊界位置

下一篇：選擇多列以在VBA中表現出色