Question

我的第一篇文章有点像。我搜索了许多论坛，并提出了经常使用的相同方法。我不熟悉并可能错过的一个选项是Autofilter。因此，基本上该对象是删除sheet1列A中列表中的所有行。如果它们存在于sheet2列A的列表中。两列只包含数字和表单一列A本身可能包含重复项，如果它们不在sheet2中的列表。

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

这就是我所拥有的：

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

一次遍历一个范围的单元格非常慢，因为每次调用Cells时都会有很大的开销。因此，您应该将两个范围都放入变量数组中，然后比较它们以构建另一个匹配数组，然后将其写回工作表并使用Autofilter选择要删除的行。这是一篇关于比较列表的各种方法的博客文章： VBA Comparing lists shootout

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

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

vba大范围重复从另一张纸删除

2 个答案: