Excel VBA – 删除重复项并保留最新（基于date栏）

有人可以帮我吗？ 我甚至不知道如何开始…我想要创build一个删除重复项（基于列A）的macros，并保留具有最新date（P列）的行。 如果所有重复项在P列中都没有date，只保留一个并删除其他重复项。

表格中的数据从第5行开始 （不像第4行那样，对不起）。 在过去我知道我有问题，删除重复通过macros时，表不开始行1或2。

表格通常有约15列和约10,000行。

有些行在P列有date，有些行不在。 因此，macros应该看是否有任何重复（列A），如果是的话，检查列P中是否有date。如果有更多的date重复，macros应删除所有重复，但保持最新。

我到目前为止使用/编辑的代码：

Sub DelDubs_Date() Dim Rng As Range Dim LastRow As Long Dim i As Long Application.ScreenUpdating = False LastRow = Cells(Rows.Count, "B").End(xlUp).Row Set Rng = Range("A5:P" & LastRow) With Rng .Sort key1:=Range("A5"), order1:=xlAscending, key2:=Range("P5"), order2:=xlDescending, _ Header:=xlYes, OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom End With For i = LastRow To 2 Step -1 If WorksheetFunction.CountIf(Range(Cells(2, "A"), Cells(i, "A")), Cells(i, "A")) > 1 Then Rows(i).Delete End If Next i Application.ScreenUpdating = True End Sub 

问题：它保持第一行，而不是最新的date…

TL; DR：检查A中的重复，然后检查P中的date，然后删除所有重复，但保持最新。 如果没有date，则删除所有重复项并保留一个。

Answer 1

由于我遇到了这里和2013年在这里描述的删除重复的错误，线程涉及到2010年，我不会指望他们在2016年修复它。 我不依赖这个函数，而是我编码：

 Sub TryMe() Call RealRemoveDuplicates("MySheet", Range("A1:C5")) End Sub Sub RealRemoveDuplicates(InSheet As String, InRange As Range) Call CreateSheets("DummyDuplicate") Sheets(InSheet).Range(InRange.Address(False, False)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _ "A1"), Unique:=True Sheets(InSheet).Range(InRange.Address(False, False)).Clear ActiveSheet.UsedRange.Copy Destination:=Sheets(InSheet).Range(InRange.Address(1)) Sheets("DummyDuplicate").Delete End Sub Sub CreateSheets(NameSheet As String, Optional Looked_Workbook As Workbook) Dim SheetExists As Worksheet If Looked_Workbook Is Nothing Then Set Looked_Workbook = ThisWorkbook '1. If Looked_Workbook Is Nothing On Error GoTo ExpectedErr01CreateSheets Set SheetExists = Looked_Workbook.Worksheets(NameSheet) SheetExists.Delete If Err.Number <> 0 Then '2. If Err.Number <> 0 ExpectedErr01CreateSheets: 'this means sheet didn't existed so, we are going to create it End If '2. If Err.Number <> 0 With Looked_Workbook .Sheets.Add After:=.Sheets(.Sheets.Count) ActiveSheet.Name = NameSheet End With End Sub 

Answer 2

将date从文本转换为date，您可以logging下这个macros：
1.按Conf. DatesortingConf. Date 从最新到最旧的Conf. Date
2.数据> Remove Duplicates >取消选中除REF列之外的所有项
3.按REF栏sorting

---

我认为这将是更简单和更灵活的智慧数据透视表或PowerPivot。

Answer 3

通常我会把所有这一切都纳入一个小组，但你似乎喜欢@John Bustos的解决scheme。 我testing了一次，似乎工作让我知道，如果我错过了什么。

 Option Explicit Dim wbk As Workbook Dim ws As Worksheet Dim lRow As Long Sub CallSubs() Call FormatDates Call SortSmall Call RemoveDups End Sub Sub FormatDates() Set wbk = Workbooks("Book1.xlsm") Set ws = wbk.Worksheets("Sheet1") With ws 'Find last row lRow = .Cells.Find(What:="*", _ After:=.Cells(1, 1), _ LookIn:=xlFormulas, _ LookAt:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row 'This will only work if Columns B through O have data 'Turn on Autofilter If .AutoFilterMode = False Then .Cells(3, 1).AutoFilter End If .Range("P4:P" & lRow).Replace What:=".", Replacement:="/", LookAt:=xlPart, MatchCase:=False .Range("P4:P" & lRow).NumberFormat = "dd/mm/yyyy;@" End With End Sub Sub SortSmall() Set wbk = Workbooks("Book1.xlsm") Set ws = wbk.Worksheets("Sheet1") With ws lRow = .Cells.Find(What:="*", _ After:=.Cells(1, 1), _ LookIn:=xlFormulas, _ LookAt:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row 'I used the macro recorder for this and cleaned it up let me know if there is a better way 'Sort Dates Z To A .AutoFilter.Sort.SortFields.Clear .AutoFilter.Sort.SortFields.add Key:=.Range("P3:P" & lRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal With .AutoFilter.Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End With End Sub Sub RemoveDups() Set wbk = Workbooks("Book1.xlsm") Set ws = wbk.Worksheets("Sheet1") With ws lRow = .Cells.Find(What:="*", _ After:=.Cells(1, 1), _ LookIn:=xlFormulas, _ LookAt:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row .Range("A3:P" & lRow).RemoveDuplicates Columns:=1, Header:=xlYes End With End Sub