vba大范围重复删除从另一个工作表

我的第一个post在这里有点儿拙劣。 我search了很多论坛，并发现了相同的方法正在使用。 我不熟悉的一个选项可能会遗漏在Autofilter上。 所以，基本上这个对象是删除sheet1列A中的所有行，如果它们存在于sheet2列A的列表中的话。两列只包含数字，而且一列A可以包含重复，如果它们不在sheet2中的列表。

现在的问题..代码执行完全在一个小的数据范围100到1000，但我有超过1,000,000logging清理的许多书籍，任何超过10,000只带来excel不响应和冻结无限期。 有什么我在这里做错了，它不能在几个小时内完成，而不是几天？ 感谢大家提前！

这就是我得到的：

Sub remDupesfromTwoWs() With Application .EnableEvents = False CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With ' set range to be searched Dim masterRecordRange As Range ' declare an unallocated array. Set masterRecordRange = Range("Sheet1!A2:A316730") ' masterRecordRange is now an allocated array ' store sheet2 column A as searchfor array Dim unwantedRecords() As Variant ' declare an unallocated array. unwantedRecords = Range("Sheet2!A1:A282393") ' unwantedRecords is now an allocated array ' foreach masterRecord loop to search masterRecordRange for match in unwantedRecords Dim i As Double Dim delRange As Range Set delRange = Range("A" & ActiveSheet.Rows.Count) 'go through all rows starting at last row For i = masterRecordRange.Rows.Count To 1 Step -1 ' loop through unwantedRecords check each offset For Each findMe In unwantedRecords 'If StrComp(cell, findMe, 1) = 0 Then not as fast ' unwantedRecord found If Cells(i, 1).Value = findMe Then Set delRange = Union(delRange, Range("A" & i)) 'MsgBox i Exit For End If Next findMe Next i 'remove them all in one shot delRange.EntireRow.Delete With Application .EnableEvents = True CalcMode = .Calculation .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With 'possibly count and display quantity found MsgBox "finally done!" End Sub 

Answer 1

每次通过一个单元格的范围非常缓慢，因为每次调用单元时都有很大的开销。 所以你应该把这两个范围都放到variables数组中，然后比较它们来构build另一个匹配数组，然后将其写回工作表并使用Autofilter来select要删除的行。 这里是一个比较列表的各种方法的博客文章： VBA比较列表枪战

最快的方法是使用字典或集合。 你应该能够调整代码来做你想做的事情。

Answer 2

你有没有试过Range.Find：

 Sub TestIt() Dim ws1 As Worksheet, ws2 As Worksheet Dim LastRow As Long, DestLast As Long, CurRow As Long Set ws1 = Sheets("Sheet1") Set ws2 = Sheets("Sheet2") LastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row DestLast = ws2.Range("A" & Rows.Count).End(xlUp).Row For CurRow = LastRow to 2 Step -1 'Must go backwards because you are deleting rows If Not ws2.Range("A2:A" & DestLast).Find(ws1.Range("A" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole) is Nothing Then Range("A" & CurRow).EntireRow.Delete xlShiftUp End If Next CurRow End Sub