[已解决]关于，删除重复数据出错的问题

yjwdjfqb

关于，删除重复数据出错的问题

在　测试1工作表中，运行代码一次　　弹出提示后，不管它

在　测试2工作表中，运行代码三次　　


上面二步操作后，就可以看到问题了。会删除不完全重复的数据行

请大家帮帮纠正下，谢谢大家了！


3.20.rar (7.62 KB, 下载次数: 19)

2014-3-20 16:06 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

xdragon

2014-3-20 17:43

1. Sub 删除完全相同行()
   
2. 
   
3.     Dim arr, rng As Range, d, i&, p$, irow&
   
4. 
   
5.     Dim s As Single
   
6.     s = Timer
   
7. 
   
8.     Application.ScreenUpdating = False
   
9.     Set d = CreateObject("scripting.dictionary")
   
10.     arr = ActiveSheet.UsedRange
    
11.     irow = ActiveSheet.UsedRange.Row
    
12.     If IsArray(arr) = False Then Exit Sub
    
13.     For i = 1 To UBound(arr)
    
14.         For j = 1 To UBound(arr, 2)
    
15.            p = p & "," & arr(i, j)
    
16.         Next
    
17.         If Not d.exists(p) Then
    
18.             d(p) = i
    
19.         Else
    
20.             If rng Is Nothing Then Set rng = Cells(i + irow - 1, 1) Else Set rng = Union(rng, Cells(i + irow - 1, 1))
    
21.         End If
    
22.         p = ""
    
23.     Next
    
24.     If Not rng Is Nothing Then rng.EntireRow.Delete
    
25.     Application.ScreenUpdating = True
    
26. 
    
27.     'MsgBox "操作完成！", vbInformation + vbOKOnly, "提示"
    
28. 
    
29.     MsgBox "耗时" & Format(Timer - s, "0.00秒"), , "提示"
    
30. 
    
31. End Sub

复制代码

你再试试，我这里运行1.34秒

跳转到最佳答案楼层

xdragon

1. Sub 删除完全相同行()
   
2.     Dim arr, rng As Range, d, i&, p$
   
3.    
   
4.     Application.ScreenUpdating = False
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     arr = ActiveSheet.UsedRange
   
7.     If IsArray(arr) = False Then Exit Sub
   
8.     For i = 1 To UBound(arr)
   
9.         p = Join(Application.Index(arr, i, 0), ",")
   
10.         If Not d.exists(p) Then
    
11.             d(p) = i
    
12.         Else
    
13.             If rng Is Nothing Then Set rng = Cells(i, 1) Else Set rng = Union(rng, Cells(i, 1))
    
14.         End If
    
15.     Next
    
16.     If Not rng Is Nothing Then rng.EntireRow.Delete
    
17.     Application.ScreenUpdating = True
    
18.    
    
19.     MsgBox "操作完成！", vbInformation + vbOKOnly, "提示"
    
20. End Sub

复制代码

当只有一个值的时候，arr不再是一个数组。。。ubound(arr)就报错了。

xdragon

Sub 删除完全相同行()
    Dim arr, rng As Range, d, i&, p$
   
    Application.ScreenUpdating = False
    Set d = CreateObject("scripting.dictionary")
    arr = ActiveSheet.UsedRange
    If IsArray(arr) = False Then Exit Sub
    For i = 1 To UBound(arr)
        p = Join(Application.Index(arr, i, 0), ",")
        If Not d.exists(p) Then
            d(p) = i
        Else
            If rng Is Nothing Then Set rng = Cells(i + ActiveSheet.UsedRange.Row - 1, 1) Else Set rng = Union(rng, Cells(i + ActiveSheet.UsedRange.Row - 1, 1))
        End If
    Next
    If Not rng Is Nothing Then rng.EntireRow.Delete
    Application.ScreenUpdating = True
   
    MsgBox "操作完成！", vbInformation + vbOKOnly, "提示"
End Sub

另一个问题是，已用区域并不是从A1开始的时候你的数组的i行和实际的行数不一致，导致删除其他行的数据

yjwdjfqb

xdragon 发表于 2014-3-20 16:18
当只有一个值的时候，arr不再是一个数组。。。ubound(arr)就报错了。

谢谢版主，当在　　测试2工作表中　　连接执行三次代码时，就会删除一个数据，但这个不是完全相同的行？？

yjwdjfqb

xdragon 发表于 2014-3-20 16:26
Sub 删除完全相同行()
    Dim arr, rng As Range, d, i&, p$
   

老师你好，功能上没有问题了，但速度还是有点慢

我在这个附件中E65536中输入了一个数据，然后执行代码，就死机，能提下速度吗

感谢了老师！

3.20-2.rar (6.15 KB, 下载次数: 6)

2014-3-20 16:41 上传

点击文件名下载附件

yjwdjfqb

能把速度提起来就太完美了！

xdragon

必须要保留单元格格式吗？

yjwdjfqb

xdragon 发表于 2014-3-20 16:56
必须要保留单元格格式吗？

老师，就是要保留单元格格式

xdragon

1. Sub 删除完全相同行()
   
2. 
   
3.     Dim arr, rng As Range, d, i&, p$, irow&
   
4. 
   
5.     Dim s As Single
   
6.     s = Timer
   
7. 
   
8.     Application.ScreenUpdating = False
   
9.     Set d = CreateObject("scripting.dictionary")
   
10.     arr = ActiveSheet.UsedRange
    
11.     irow = ActiveSheet.UsedRange.Row
    
12.     If IsArray(arr) = False Then Exit Sub
    
13.     For i = 1 To UBound(arr)
    
14.         For j = 1 To UBound(arr, 2)
    
15.            p = p & "," & arr(i, j)
    
16.         Next
    
17.         If Not d.exists(p) Then
    
18.             d(p) = i
    
19.         Else
    
20.             If rng Is Nothing Then Set rng = Cells(i + irow - 1, 1) Else Set rng = Union(rng, Cells(i + irow - 1, 1))
    
21.         End If
    
22.         p = ""
    
23.     Next
    
24.     If Not rng Is Nothing Then rng.EntireRow.Delete
    
25.     Application.ScreenUpdating = True
    
26. 
    
27.     'MsgBox "操作完成！", vbInformation + vbOKOnly, "提示"
    
28. 
    
29.     MsgBox "耗时" & Format(Timer - s, "0.00秒"), , "提示"
    
30. 
    
31. End Sub

复制代码

你再试试，我这里运行1.34秒

yjwdjfqb

xdragon 发表于 2014-3-20 17:43
你再试试，我这里运行1.34秒

超级快，是不是，也是时删除了完全为空的行