删除编号相同的重复项，保留最新日期的项

smqppiya

在这个查询表中，因为重复了几年的提取，又没有对重复选项进行覆盖的功能，然后就出现了很多很多的重复项，每次使用起来很是苦恼。希望各位大神帮忙写代码，删除编号相同的重复项，保留最新日期的那个数据。

smqppiya

补充下，说的编号是指表中证书号即D列的数据。

cui26896

1. Option Explicit
   
2. Sub test()
   
3. Dim i&, j&, arr, brr, arr2, k, d As Object
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. With Sheets(1)
   
6. .Activate
   
7. arr2 = Array("企业名称", "产品名称", "型号规格", "证书号", "更新时间")
   
8. arr = .Range("a2").Resize(.Cells(Rows.Count, 1).End(xlUp).Row, .Cells(1, Columns.Count).End(xlToLeft).Column)
   
9. ReDim brr(1 To UBound(arr), 1 To 5)
   
10. End With
    
11. For i = 1 To UBound(arr)
    
12.   If Not (d.exists(arr(i, 4))) Then
    
13.     If arr(i, 5) >= "2019/1/1" Then
    
14.       k = k + 1
    
15.       d(arr(i, 4)) = k
    
16.       brr(d(arr(i, 4)), 1) = arr(i, 1)
    
17.       brr(d(arr(i, 4)), 2) = arr(i, 2)
    
18.       brr(d(arr(i, 4)), 3) = arr(i, 3)
    
19.       brr(d(arr(i, 4)), 4) = arr(i, 4)
    
20.       brr(d(arr(i, 4)), 5) = arr(i, 5)
    
21.     End If
    
22.   End If
    
23. Next
    
24. With Sheets(2)
    
25. .Activate
    
26. .Range("a1").Resize(1, 5) = arr2
    
27. .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
28. End With
    
29. End Sub
    

复制代码

renkangjizhen

1、先以证书号为第一关键字、更新时间为第二关键字对原表格数据区域进行升序排序
2.对证书号所在列数据区域单元格进行循环，如果单元格值等于下一单元格值，则将该单元格所在行删除

smqppiya

renkangjizhen 发表于 2019-12-9 20:40
1、先以证书号为第一关键字、更新时间为第二关键字对原表格数据区域进行升序排序
2.对证书号所在列数据区 ...

感谢大佬的代码，但是运行后发现把2019/1/1以前的全部都删除了，即使没重复的也删除了。

一指禅62

1. Sub 证书号最后更新时间()
   
2.     Dim arr, i&, a(), m&, n&, S$, d As Object
   
3.     arr = Sheet1.Range("A1").CurrentRegion
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     For i = 2 To UBound(arr)
   
6.         S = arr(i, 4)
   
7.         If Not d.Exists(S) Then
   
8.             n = n + 1: ReDim Preserve a(1 To 5, 1 To n)
   
9.             a(1, n) = arr(i, 1)
   
10.             a(2, n) = arr(i, 2)
    
11.             a(3, n) = arr(i, 3)
    
12.             a(4, n) = "'" & arr(i, 4)
    
13.             a(5, n) = arr(i, 5)
    
14.             d(arr(i, 4)) = n
    
15.         Else
    
16.             m = d.Item(S)
    
17.             If a(5, m) < arr(i, 5) Then
    
18.                 a(2, m) = arr(i, 2)
    
19.                 a(3, m) = arr(i, 3)
    
20.                 a(5, m) = arr(i, 5)
    
21.             End If
    
22.         End If
    
23.     Next
    
24.     Sheet2.Range("A2:E65536").ClearContents
    
25.     Sheet2.Range("A2").Resize(n, 5) = WorksheetFunction.Transpose(a)
    
26. End Sub

复制代码

wj2368

smqppiya 发表于 2019-12-11 09:04
感谢大佬的代码，但是运行后发现把2019/1/1以前的全部都删除了，即使没重复的也删除了。

。。。。。。。。。。。。。。。。。。

smqppiya

wj2368 发表于 2019-12-11 09:43
。。。。。。。。。。。。。。。。。。

非常谢谢，按你的附件已解决问题！拜谢！

smqppiya

一指禅62 发表于 2019-12-11 09:27

谢谢大大的代码。

cui26896

测试一下，只要把    If arr(i, 5) >= "2019/1/1" Then屏蔽，结果与6楼的完全一样，也是237个。

1. Sub test()
   
2. Dim i&, j&, arr, brr, arr2, k, d As Object
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. With Sheets(1)
   
5. .Activate
   
6. arr2 = Array("???????", "???????", "?????", "????", "???????")
   
7. arr = .Range("a2").Resize(.Cells(Rows.Count, 1).End(xlUp).Row, .Cells(1, Columns.Count).End(xlToLeft).Column)
   
8. ReDim brr(1 To UBound(arr), 1 To 5)
   
9. End With
   
10. For i = 1 To UBound(arr)
    
11.   If Not (d.Exists(arr(i, 4))) Then
    
12. '    If arr(i, 5) >= "2019/1/1" Then
    
13.       k = k + 1
    
14.       d(arr(i, 4)) = k
    
15.       brr(d(arr(i, 4)), 1) = arr(i, 1)
    
16.       brr(d(arr(i, 4)), 2) = arr(i, 2)
    
17.       brr(d(arr(i, 4)), 3) = arr(i, 3)
    
18.       brr(d(arr(i, 4)), 4) = arr(i, 4)
    
19.       brr(d(arr(i, 4)), 5) = arr(i, 5)
    
20. '    End If
    
21.   End If
    
22. Next
    
23. With Sheets(2)
    
24. .Activate
    
25. .Range("a1").Resize(1, 5) = arr2
    
26. .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
27. End With
    
28. End Sub

复制代码