[已解决]请指教：查找并自动删除重复行！！！！

KDZ

    求：各列的并列条件同时成立：即第1列，并第2列，并第5列，并第8列，的同一内容在本列重复，并第17列为“1”，并第22列为空，并第29列为“1”时，删除所有符合上述并列条件的所有重复行，但必须保留符合上述并列条件的所有重复行中的一行的VBA数组代码，注意是数组方法！！         请高手指教，跪求！急用，谢谢！！
    以下是原来没有用数组的代码，怎么转化为数组法？请帮忙！  

Sub 删除复行() [

Dim ROW As Integer

Dim i As Integer

ROW = Range("D65536").End(xlUp).Row

For i = 1 To ROW

For j = i + 1 To ROW

If Cells(j, 1) = Cells(i, 1) And Cells(j, 2) = Cells(i, 2) And Cells(j, 5) = Cells(i, 5) And Cells(j, 8) = Cells(i, 8) And Cells(j, 17) = 1 And Cells(j, 22) = "" And Cells(j, 29) = 1 Then

Range(Cells(j, 1), Cells(j, 256)).Rows.Delete

j = j - 1

ROW = ROW - 1

End If

Next

Next

最佳答案

月排行榜 / 总排行榜

dsmch

2014-2-27 15:27

1. Sub Macro1()
   
2. Dim arr, rng As Range, d, d2, i&, x$
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. arr = [a1:af11]
   
6. For i = 4 To UBound(arr)
   
7.     x = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 5) & "," & arr(i, 8)
   
8.     If Not d.exists(x) Then
   
9.         d(x) = ""
   
10.     Else
    
11.         If arr(i, 17) = 1 And arr(i, 22) = "" And arr(i, 29) = 1 Then
    
12.             If Not d2.exists(x) Then
    
13.                 d2(x) = ""
    
14.             Else
    
15.                 If rng Is Nothing Then Set rng = Cells(i, 1) Else Set rng = Union(rng, Cells(i, 1))
    
16.             End If
    
17.         End If
    
18.     End If
    
19. Next
    
20. If Not rng Is Nothing Then rng.EntireRow.Delete
    
21. End Sub
    

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, rng As Range, d, i&, x$
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = [a1:af11]
   
5. For i = 4 To UBound(arr)
   
6.     x = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 5) & "," & arr(i, 8)
   
7.     If Not d.exists(x) Then
   
8.         d(x) = ""
   
9.     Else
   
10.         If arr(i, 17) = 1 And arr(i, 22) = "" And arr(i, 29) = 1 Then
    
11.             If rng Is Nothing Then Set rng = Cells(i, 1) Else Set rng = Union(rng, Cells(i, 1))
    
12.         End If
    
13.     End If
    
14. Next
    
15. If Not rng Is Nothing Then rng.EntireRow.Delete
    
16. End Sub
    

复制代码

dsmch

………………

KDZ

dsmch 发表于 2014-2-27 14:14
………………

非常感谢！！就差一步了，你这个代码是将2.6.7行全部删除了。我要的是：将序号2、6、7这三行中任意删除二行，但必要保留一行。我的意思是：只有2.6.7行完全符合我的删除条件，但必须保留其中一行来用。再次麻烦你一下，谢谢。

dsmch

1. Sub Macro1()
   
2. Dim arr, rng As Range, d, d2, i&, x$
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. arr = [a1:af11]
   
6. For i = 4 To UBound(arr)
   
7.     x = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 5) & "," & arr(i, 8)
   
8.     If Not d.exists(x) Then
   
9.         d(x) = ""
   
10.     Else
    
11.         If arr(i, 17) = 1 And arr(i, 22) = "" And arr(i, 29) = 1 Then
    
12.             If Not d2.exists(x) Then
    
13.                 d2(x) = ""
    
14.             Else
    
15.                 If rng Is Nothing Then Set rng = Cells(i, 1) Else Set rng = Union(rng, Cells(i, 1))
    
16.             End If
    
17.         End If
    
18.     End If
    
19. Next
    
20. If Not rng Is Nothing Then rng.EntireRow.Delete
    
21. End Sub
    

复制代码

KDZ

dsmch 发表于 2014-2-27 15:27

再次感谢！这个代码对我这个表是达到目标了，但我测试一下，如果将原表5--11行复制一下在下面，这个新复制表的第6、7、2行就不能删除了，也应当和上一个5——11行的6、7、2行一样只保留一下啊，怎么不行？再请你麻烦一下，谢谢！！

dsmch

KDZ 发表于 2014-2-27 15:52
再次感谢！这个代码对我这个表是达到目标了，但我测试一下，如果将原表5--11行复制一下在下面，这个新复制 ...

第五行代码修改为：
arr = ActiveSheet.UsedRange

KDZ

dsmch 发表于 2014-2-27 16:01
第五行代码修改为：
arr = ActiveSheet.UsedRange

行了，非常感谢你，只是代码不少看不懂，以后多你学习！[em17]

KDZ

dsmch 发表于 2014-2-27 16:01
第五行代码修改为：
arr = ActiveSheet.UsedRange

不好意思，

dsmch

If arr(i, 17) = "" And ( arr(i, 18) = 1 or arr(i, 19) = 1) Then