[已解决]哪位老师有，VBA删除当前工作表，完全数据重复的数据行，只保留一行

yjwdjfqb

哪位老师有，VBA删除当前工作表，完全数据重复的数据行，只保留一行

或者帮帮我写一个，谢谢大家了！


附件.rar (1.74 KB, 下载次数: 14)

2014-3-18 19:07 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2014-3-19 13:52

1. Sub Macro1()
   
2. Dim arr, rng As Range, d, i&, x%, p$
   
3. Application.ScreenUpdating = False
   
4. Application.StatusBar = "正在删除中……"
   
5. Set d = CreateObject("scripting.dictionary")
   
6. '第一步删除空行
   
7. arr = ActiveSheet.UsedRange
   
8. x = UBound(arr, 2)
   
9. For i = 1 To UBound(arr)
   
10.     If Application.CountA(Cells(i, 1).Resize(1, x)) = 0 Then
    
11.         If rng Is Nothing Then Set rng = Cells(i, 1) Else Set rng = Union(rng, Cells(i, 1))
    
12.     End If
    
13. Next
    
14. If Not rng Is Nothing Then rng.EntireRow.Delete
    
15. Set rng = Nothing
    
16. '第二步删除重复行
    
17. arr = ActiveSheet.UsedRange
    
18. For i = 1 To UBound(arr)
    
19.     p = Join(Application.Index(arr, i, 0), ",")
    
20.     If Not d.exists(p) Then
    
21.      d(p) = i
    
22.     Else
    
23.         If rng Is Nothing Then Set rng = Cells(i, 1) Else Set rng = Union(rng, Cells(i, 1))
    
24.     End If
    
25. Next
    
26. If Not rng Is Nothing Then rng.EntireRow.Delete
    
27. Application.StatusBar = "删除完毕，OK"
    
28. Application.ScreenUpdating = True
    
29. End Sub
    

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, d, rng As Range, i&, p$
   
3. t = Timer
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = Range("a1").CurrentRegion
   
6. For i = 1 To UBound(arr)
   
7.     p = ""
   
8.     For j = 1 To UBound(arr, 2)
   
9.         p = p & "," & arr(i, j)
   
10.     Next
    
11.     If Not d.exists(p) Then
    
12.         d(p) = ""
    
13.     Else
    
14.         If rng Is Nothing Then Set rng = Cells(i, 1) Else Set rng = Union(rng, Cells(i, 1))
    
15.     End If
    
16. Next
    
17. If Not rng Is Nothing Then rng.EntireRow.Delete
    
18. MsgBox Timer - t
    
19. End Sub
    

复制代码

dsmch

………………

dsmch

1. Sub Macro1()
   
2. Dim arr, d, rng As Range, i&, p$
   
3. t = Timer
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = Range("a1").CurrentRegion
   
6. For i = 1 To UBound(arr)
   
7.     p = Join(Application.Index(arr, i, 0), ",")
   
8.     If Not d.exists(p) Then
   
9.         d(p) = ""
   
10.     Else
    
11.         If rng Is Nothing Then Set rng = Cells(i, 1) Else Set rng = Union(rng, Cells(i, 1))
    
12.     End If
    
13. Next
    
14. If Not rng Is Nothing Then rng.EntireRow.Delete
    
15. MsgBox Timer - t
    
16. End Sub
    

复制代码

再提供一种方法，两种方法速度差不多

风林火山

1. Sub 删除重复行()
   
2.     Dim arr(), k%, n%, d, str$ '定义变量
   
3.     Set d = CreateObject("scripting.dictionary") '创建字典去重
   
4.     For k = 1 To Range("b65536").End(xlUp).Row '循环建立字典，并对重复数据的行数进行记录
   
5.         str = Cells(k, 2) & Cells(k, 3) & Cells(k, 4) & Cells(k, 5) & Cells(k, 6) '建立字典关键字字符串
   
6.         If Not d.exists(str) Then '判断关键字在字典中是否存在
   
7.             d(str) = "" '不存在，添加到字典中
   
8.         Else '存在
   
9.             n = n + 1 '数组计数
   
10.             ReDim Preserve arr(1 To n) '重新定义数组
    
11.             arr(n) = k '向数组中添加重复数据所在的行号
    
12.         End If
    
13.     Next
    
14.     For k = UBound(arr) To 1 Step -1 'x循环删除重复行
    
15.         Range("a" & arr(k)).EntireRow.Delete
    
16.     Next
    
17. End Sub
    

复制代码

yjwdjfqb

dsmch 发表于 2014-3-18 19:16
再提供一种方法，两种方法速度差不多

朋友你好，感谢你的帮助，第二种好像要快点

但，工作表，数据行间有完全的空行，就不会执行成功，

能不能，先把数据间的空行（整行完全是空的），删除后，再执行删除完全相同的行，保留一行

附件2.rar (5.87 KB, 下载次数: 12)

2014-3-18 19:24 上传

点击文件名下载附件

hwc2ycy

10有个去重复的功能。

风林火山

yjwdjfqb 发表于 2014-3-18 19:24
朋友你好，感谢你的帮助，第二种好像要快点

但，工作表，数据行间有完全的空行，就不会执行成功，

Sub test()
    Dim arr As Range, k%
    k = Cells(Rows.Count, 2).End(3).Row
    ActiveSheet.Range("b1:F" & k).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlYes
    Columns("B:B").SpecialCells(xlCellTypeBlanks).Select
    Selection.EntireRow.Delete
End Sub

yjwdjfqb

hwc2ycy 发表于 2014-3-18 19:27
10有个去重复的功能。

版主，单位都是用的2003的哟！

张雄友

以上都不对吧，答案怎么有二条记录一样的？

1

0

2

这样？
Sub 删除内容完全重复的行()
     Dim cnn, SQL$
     Set cnn = CreateObject("adodb.connection")
     cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
     SQL = "SELECT DISTINCT * FROM [SHEET1$A2:C65536]"  '
     Sheets("SHEET2").Range("A2").CopyFromRecordset cnn.Execute(SQL)
     cnn.Close
     Set cnn = Nothing
End Sub