Question

我有两个问题。

为什么我的宏只会在第一次运行时删除大约50％的重复项？当我再次运行它时，它完成并删除其余的。（我试过2,000行和9,000行，结果是一样的，第一次尝试只有50％，第二次只有50％）

我知道我正在筛选大量数据（A列和B列中的数据量高达9,000+）但是有什么明显的东西看起来我可以改变以加快速度吗？目前第一次运行大约需要5分钟，第二次运行需要2分钟，此时我有正确的数据。我目前有我的主宏设置来运行这个宏两次。

Sub RemoveDuplicateFromOneColumnComparingWithAnother()
'Delete column header I don't need'
Rows("1:1").Select
Selection.Delete Shift:=xlUp
'First I remove duplicates from Column B, Column A already has only Unique values' 

Columns("B:B").Select
ActiveSheet.Range("B:B").RemoveDuplicates Columns:=1, Header:= _
xlNo
'Now I compare columns A and B, and and delete any matching values from column A'
Application.ScreenUpdating = False
Dim rngCell As Range
Dim rngCheck As Range
For Each rngCell In Range("A1").CurrentRegion.Columns(2).Cells
If Not IsEmpty(rngCell) Then
    Do
        Set rngCheck = Nothing
        On Error Resume Next
        Set rngCheck = Range("A1").CurrentRegion.Columns(1).Find("*" & rngCell.Value & "*")
        rngCheck.ClearContents
        Err.Clear: On Error GoTo -1: On Error GoTo 0
    Loop Until rngCheck Is Nothing

End If
Next rngCell
Set rngCell = Nothing
Set rngCheck = Nothing

End Sub

Answer 1

我认为你的嵌套Do ... Loop正在减慢它的速度。我实际上根本没有看到需要在那里循环。

On Error Resume Next
If Not IsEmpty(rngCell) Then
    set rngcheck = Range("A1").CurrentRegion.Columns(1).Find("*" & rngCell.Value & "*")
    If Not rngcheck is Nothing then
        rngcheck.ClearContents
    End if
End If

如何加速/修复我的宏，比较2列并删除第一列中的重复项

1 个答案: