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

张雄友

D9单元格有个空格，楼主真是用心良苦

1. Sub 删除内容完全重复的行()
   
2.    [E1:G1] = Array("标题1", "标题2", "标题3")
   
3.      Dim cnn, SQL$
   
4.      Set cnn = CreateObject("adodb.connection")
   
5.      cnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
   
6.      SQL = "SELECT DISTINCT * FROM [SHEET1$A2:D65536]"  '
   
7.      Range("E2").CopyFromRecordset cnn.Execute(SQL)
   
8.      cnn.Close
   
9.      Set cnn = Nothing
   
10. End Sub

复制代码

dsmch

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

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

1. Sub Macro2()
   
2. Dim arr, d, rng As Range, i&, p$
   
3. t = Timer
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = Range("b1:f" & Range("b65536").End(xlUp).Row)
   
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) = i
   
10.     Else
    
11.         If rng Is Nothing Then Set rng = Cells(i, 2) Else Set rng = Union(rng, Cells(i, 2))
    
12.     End If
    
13. Next
    
14. zf = String(UBound(arr, 2) - 1, ",")
    
15. If d.exists(zf) Then
    
16.     If rng Is Nothing Then Set rng = Cells(d(zf), 2) Else Set rng = Union(rng, Cells(d(zf), 2))
    
17. End If
    
18. If Not rng Is Nothing Then rng.EntireRow.Delete
    
19. MsgBox Timer - t
    
20. End Sub
    

复制代码

yjwdjfqb

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

老师你好，这个代码弹出，错误13，请帮帮斧正下好吧，

谢谢了！

删除完全相同行.rar (7.21 KB, 下载次数: 2)

2014-3-19 13:31 上传

点击文件名下载附件

dsmch

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
    

复制代码