Performance 使用VBA删除基于其他工作表中列出的单词的行-性能低下

我有一张有大量数据的表（表1）。此数据有多个列，其中一个称为nameColumn。nameColumn每行包含一个单词

在表2中，我列出了600个单词

我需要删除sheet1中包含与sheet2中的单词匹配的nameColumn中的每一行

我已经按照名称列的字母顺序对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

---

请参阅以下代码中的注释。它在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数据行，而是在Sheet3中创建数据的新副本（不包括具有匹配单词的行）。接下来的步骤是删除Sheet1并重命名和移动Sheet3（我没有在代码中包括这些步骤）

代码将Sheet1中的nameColumn和Sheet2中的wordColumn复制到VBA数组中。它在nameColumn数组中循环搜索wordColumn数组中的匹配项。为了加快匹配过程，在匹配之前对Sheet2中的单词列表进行排序。找到匹配项后，将在结果数组中设置标志值1

然后，它将结果数组写回Sheet1，并在Sheet1数据范围上设置自动筛选，以排除具有匹配字的行。最后一步是将过滤后的数据复制到Sheet3

我在一个42000字的nameColumn上测试了该代码，其中包含26列随机数字数据，与从nameColumn字中随机抽取的600字排序列表相匹配。代码运行大约需要5秒钟，其中80%的时间花在单词匹配循环中。（我还测试了删除匹配行的代码版本，这一更改使执行时间增加了一倍。）

Sub-filteronomatchandcopy（）
将ws1标注为工作表，ws2标注为工作表，ws3标注为工作表
调暗ws1LastCell作为范围，ws2LastCell作为范围
尺寸值arr（），搜索arr（），结果器（）
我和我一样长，我和我一样长
Dim sort_Sheet2_列表为布尔值
排序表2\u列表=真
应用
.ScreenUpdate=False
.EnableEvents=False
以
设置ws1=ActiveWorkbook.Worksheets（“Sheet1”）
设置ws2=ActiveWorkbook.Worksheets（“Sheet2”）
'如果不存在，请创建Sheet3，如果存在，请清除它
设置ws3=无
出错时继续下一步
设置ws3=ActiveWorkbook.Worksheets（“Sheet3”）
错误转到0
如果ws3什么都不是，那么
Worksheets.Add（在：=ws2之后）。Name=“Sheet3”
设置ws3=ActiveWorkbook.Worksheets（“Sheet3”）
如果结束
ws3.Cells.Clear
'查找已使用范围中的最后一个单元格
使用ws1
设置ws1LastCell=.Cells（.Cells.Find（内容：=“*”，搜索顺序：=xlRows_
SearchDirection:=xlPrevious，LookIn:=xlFormulas）。行_
.Cells.Find（内容：=“*”，搜索顺序：=xlByColumns_
SearchDirection:=xlPrevious，LookIn:=xlFormulas）.Column）
以
与ws2
设置ws2LastCell=.Cells（.Cells.Find（内容：=“*”，搜索顺序：=xlRows_
SearchDirection:=xlPrevious，LookIn:=xlFormulas）。行_
.Cells.Find（内容：=“*”，搜索顺序：=xlByColumns_
SearchDirection:=xlPrevious，LookIn:=xlFormulas）.Column）
以
'将nameColumn和wordColumn复制到VBA数组中
'（如果nameColumn和wordColumn不在A列中，请在此处更改）
valueArr=ws1.Range（$A$2:$A$”&ws1LastCell.Row）
如果是排序表2，则
ws2.Range（$A$2:$A$”&ws2LastCell.Row）。排序键1:=ws2.Range（“A2”）_
订单1:=xl升序，标题：=xlNo
如果结束
searchArr=ws2.Range（$A$2:$A$”&ws2LastCell.Row）
'创建一个新数组，该数组将标记nameColumn中匹配的单词
重拨结果器（LBound（valueArr，1）到UBound（valueArr，1），1到1）
'搜索匹配项
对于i=1到UBound（值arr，1）
j=1
当j<（UBound（搜索arr，1）+1）时执行
如果valueArr（i，1）>searchArr（j，1），则
j=j+1
其他的
如果valueArr（i，1）=searchArr（j，1），则
结果r（i，1）=1
如果结束
j=UBound（搜索arr，1）+1
如果结束
环
下一个
'将匹配结果写入Sheet1，将autofilter设置为排除匹配，
'并将结果复制到第3页
使用ws1
.Cells（1，ws1LastCell.Column+1）。value=“已找到”
.Range（.Cells（2，ws1LastCell.Column+1）_
.Cells（ws1LastCell.Row，ws1LastCell.Column+1））=_
结果者
.Range（“A1”）.AutoFilter ws1LastCell.Column+1，“1”
.Range（.Cells（1，1），.Cells（ws1LastCell.Row，ws1LastCell.Column））。复制目标：=ws3.Range（“A1”）
.AutoFilterMode=False
.Cells（1，ws1LastCell.Column+1）.entireclumn.Delete
以
应用
.ScreenUpdate=True
.EnableEvents=True
以
端接头

我怀疑对sheet2 Word列上的name列进行匹配（使用match或vlookup），然后在sheet1上设置自动筛选，筛选出不需要的行