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

smqppiya

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

smqppiya

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

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

谢谢大大的代码。