使用VBA刪除基於另一個表中列出的單詞的行 - 性能較差

Question

我有一個包含大量數據的工作表（表單1）。這些數據有幾列，其中之一叫做nameColumn。 nameColumn每行包含一個單詞。

在表2中，我有一個600字的列表。

我需要刪除工作表Sheet1從每一行包含在名稱列一個字，在Sheet2中

我按字母順序排序的名稱列工作表Sheet1匹配的詞，也整理Sheet2中按字母順序。

我寫的代碼很有作用，但它很糟糕。它爲表1中的行數創建一個for循環，並在其中嵌套一個while循環，用於比較兩個工作表之間的值，如果在nameColumn中找到匹配項，則刪除該行。我試圖通過告訴while循環來「優化」它，如果sheet1中的單詞按字母順序「比sheet2中的單詞更大」，則只增加「i」。

這段代碼需要20分鐘才能做〜10k行。我怎樣才能讓它更快？

請注意，我已經嘗試更改代碼以將不匹配的行復制到另一個工作表，這似乎只是一個慢。 我也看過這篇文章，坦率地說，我不太瞭解它來嘗試實現它。

Sub removerows3() 
Application.ScreenUpdating = False 

Dim numberof_data_rows As Long 
numberof_data_rows = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row 

Dim numberof_alert_rows As Long 
numberof_alert_rows = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row 

Dim nameColumn As Integer 
nameColumn = 3 

Dim current_alert_row As Integer 
current_alert_row = 2 

Dim current_data_row As Long 
current_data_row = 2 

Dim keep_searching_dosealert As Integer 
keep_searching_dosealert = 1 


For current_data_row = 2 To numberof_data_rows 


Do While keep_searching_dosealert = 1 
    If Sheet2.Cells(current_alert_row, 1) = Cells(current_data_row, nameColumn) 
     Cells(current_data_row, nameColumn).EntireRow.Delete 
     keep_searching_dosealert = 0 
     current_data_row = current_data_row - 1 
     numberof_data_rows = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row 

    ElseIf StrComp(Sheet2.Cells(current_alert_row, 1), Sheet1.Cells(current_data_row, nameColumn)) = 1 Then 
     keep_searching_dosealert = 0 
     current_alert_row = current_alert_row - 1 

    ElseIf StrComp(Sheet2.Cells(current_alert_row, 1), Sheet1.Cells(current_data_row, nameColumn)) = -1 Then 
     keep_searching_dosealert = 1 
     current_alert_row = current_alert_row + 1 
    Else 
     MsgBox ("error") 

    End If 
Loop 
keep_searching_dosealert = 1 


Next current_data_row 

End Sub 

Answer 1

請參閱以下代碼中的註釋。它在Sheet1右側的列中創建一個臨時數組公式。它在我們正在檢查的列右側20列 - 如有必要，增加此數字。

Sub DeleteAcross2() 
    Dim calc As Variant 
    Dim ws1 As Worksheet 
    Dim ws2 As Worksheet 
    Dim rng1 As Range 
    Dim rng2 As Range 
    Dim dels As Variant 
    Dim x As Long 
    Dim rngDel As Range 

    Application.ScreenUpdating = False 
    'remember the Calculation Mode to reinstate later 
    calc = Application.Calculation 
    Application.Calculation = xlCalculationManual 

    Set ws1 = Worksheets("Sheet1") 
    Set rng1 = ws1.Range("B2:B70")  'change this range 
    Set ws2 = Worksheets("Sheet2") 
    Set rng2 = ws2.Range("A1:A4")  'change this range 

    'add a formula-column 20 columns to the right - increase this number if necessary 
    rng1.Offset(0, 20).FormulaArray = "=ISNA(MATCH(Sheet1!$B$2:$B$70,Sheet2!$A$1:$A$4,0))" 
    'creates a column of True/False values - we will delete rows with False 
    dels = rng1.Offset(0, 20).Value 
    For x = 1 To UBound(dels, 1) 
     If dels(x, 1) = False Then 
      If rngDel Is Nothing Then 
       Set rngDel = rng1.Cells(x, 1)  'the first cell 
      Else 
       Set rngDel = Union(rngDel, rng1.Cells(x, 1)) 
      End If 
     End If 
    Next x 
    rng1.Offset(0, 20).Clear  'remove the array-formula (required) 
    If rngDel Is Nothing Then Exit Sub  'no matches found 
    rngDel.EntireRow.Delete 
    Application.Calculation = calc 
    Application.ScreenUpdating = True 
End Sub 

它不會需要20分鐘，而不是刪除工作表Sheet1的數據行與匹配詞運行:)

Answer 2

，下面的代碼創建數據的新副本 - 不包括與行匹配單詞 - 在Sheet3中。接下來的步驟是刪除Sheet1並重命名並移動Sheet3（我沒有在代碼中包含這些步驟）。

該代碼將Sheet1中的nameColumn和Sheet2中的wordColumn複製到VBA數組中。它通過nameColumn數組循環搜索wordColumn數組中的匹配項。爲了加速匹配過程，Sheet2中的單詞列表在匹配之前進行排序。如果找到匹配項，則在結果數組中設置標誌值1。

然後，它將結果數組寫回到Sheet1，並在Sheet1數據範圍上設置一個自動過濾器，以排除具有匹配字的行。最後一步是將過濾的數據複製到Sheet3。

我測試了一個42,000字nameColumn上的代碼，其中包含26列隨機數字數據，與從列名詞中隨機抽取的已排序的600字列表匹配。代碼花費了大約5秒鐘的時間，其中80％的時間用在了單詞匹配循環中。 （I還測試一個版本的代碼已刪除代替匹配的行，這增加了一倍的執行時間的變化。）

Sub FilterOnNoMatchAndCopy() 

    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet 
    Dim ws1LastCell As Range, ws2LastCell As Range 
    Dim valueArr(), searchArr(), resultArr() 
    Dim i As Long, j As Long 
    Dim sort_Sheet2_list As Boolean 

    sort_Sheet2_list = True 

    With Application 
     .ScreenUpdating = False 
     .EnableEvents = False 
    End With 

    Set ws1 = ActiveWorkbook.Worksheets("Sheet1") 
    Set ws2 = ActiveWorkbook.Worksheets("Sheet2") 

' create Sheet3 if it doesn't exist, clear it if it does 
    Set ws3 = Nothing 
    On Error Resume Next 
    Set ws3 = ActiveWorkbook.Worksheets("Sheet3") 
    On Error GoTo 0 
    If ws3 Is Nothing Then 
     Worksheets.Add(After:=ws2).Name = "Sheet3" 
     Set ws3 = ActiveWorkbook.Worksheets("Sheet3") 
    End If 
    ws3.Cells.Clear 

' Find last cell in used ranges 
    With ws1 
     Set ws1LastCell = .Cells(.Cells.Find(What:="*", SearchOrder:=xlRows, _ 
      SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row, _ 
      .Cells.Find(What:="*", SearchOrder:=xlByColumns, _ 
      SearchDirection:=xlPrevious, LookIn:=xlFormulas).Column) 
    End With 
    With ws2 
     Set ws2LastCell = .Cells(.Cells.Find(What:="*", SearchOrder:=xlRows, _ 
      SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row, _ 
      .Cells.Find(What:="*", SearchOrder:=xlByColumns, _ 
      SearchDirection:=xlPrevious, LookIn:=xlFormulas).Column) 
    End With 

' copy the nameColumn and wordColumn into VBA arrays 
' (if nameColumn and wordColumn are not in column A, change here)  
    valueArr = ws1.Range("$A$2:$A$" & ws1LastCell.Row) 
    If sort_Sheet2_list Then 
     ws2.Range("$A$2:$A$" & ws2LastCell.Row).Sort Key1:=ws2.Range("A2"), _ 
      Order1:=xlAscending, Header:=xlNo 
    End If 
    searchArr = ws2.Range("$A$2:$A$" & ws2LastCell.Row) 

' create a new array that will flag which words in nameColumn are matches 
    ReDim resultArr(LBound(valueArr, 1) To UBound(valueArr, 1), 1 To 1) 

' search for matches 
    For i = 1 To UBound(valueArr, 1) 
     j = 1 
     Do While j < (UBound(searchArr, 1) + 1) 
      If valueArr(i, 1) > searchArr(j, 1) Then 
       j = j + 1 
      Else 
       If valueArr(i, 1) = searchArr(j, 1) Then 
        resultArr(i, 1) = 1 
       End If 
       j = UBound(searchArr, 1) + 1 
      End If 
     Loop 
    Next 

' write match results to Sheet1, set autofilter to exclude matches, 
'  and copy result to Sheet3 
    With ws1 
     .Cells(1, ws1LastCell.Column + 1).value = "found" 
     .Range(.Cells(2, ws1LastCell.Column + 1), _ 
      .Cells(ws1LastCell.Row, ws1LastCell.Column + 1)) = _ 
      resultArr 
     .Range("A1").AutoFilter ws1LastCell.Column + 1, "<>1" 
     .Range(.Cells(1, 1), .Cells(ws1LastCell.Row, ws1LastCell.Column)).Copy Destination:=ws3.Range("A1") 
     .AutoFilterMode = False 
     .Cells(1, ws1LastCell.Column + 1).EntireColumn.Delete 
    End With 

    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
    End With 

End Sub