search和删除VBA代码需要优化

我有一个Excel工作簿2张（ProductList和CurrentProducts）

我有以下代码：

Sub Macro1() Dim Lastrow As Integer Dim x As Integer Dim BinNo As String Dim MyCell As Range Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Lastrow = Sheets("ProductsList").Range("A65536").End(xlUp).Row For x = Lastrow To 2 Step -1 BinNo = Sheets("ProductsList").Range("A" & x).Value With Sheets("CurrentProducts").Range("A:A") Set MyCell = .Find(What:=BinNo, _ After:=.Cells(.Cells.Count), _ LookIn:=xlValues, _ LookAt:=xlWhole, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False) If Not MyCell Is Nothing Then Sheets("CurrentProducts").Range(MyCell.Address).EntireRow.Delete End If End With Next Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub 

这样做是从ProductList中的列A中获取每个值，然后在CurrentProducts中search它，如果它find该值，则从CurrentProducts中删除整个行，以便在CurrentProducts表中留下任何新产品。

此代码工作，但非常缓慢，大约需要5分钟运行。

每张纸约有30,000行。

有没有办法加快速度，还是因为有这么多行？

Answer 1

我build议通过使用公式可以更快地完成这个任务。 比如你可以做一个vlookup。 然后，您可以对工作表进行sorting，并删除返回值的任何行。

这是一个可能的解决scheme。

我可以想到很多类似的东西。 但使用公式将是最简单的。

Answer 2

你可以尝试这样的事情…

 Sub DeleteRows() Dim ws1 As Worksheet, ws2 As Worksheet Dim lr As Long Application.ScreenUpdating = False Set ws1 = Sheets("ProductsList") Set ws2 = Sheets("CurrentProducts") With ws2 lr = .Cells(Rows.Count, 1).End(xlUp).Row .Columns(1).Insert .Range("A2:A" & lr).Formula = "=IF(COUNTIF(" & ws1.Name & "!A:A,B2),NA(),"""")" On Error Resume Next .Range("A2:A" & lr).SpecialCells(xlCellTypeFormulas, 16).EntireRow.Delete .Columns(1).Delete End With Application.ScreenUpdating = True End Sub