Question

有人能帮助我吗？我甚至不知道如何开始...... 我想创建一个删除重复项的宏（基于列A）并保留具有最新日期（列P）的行。如果所有重复项在P列中都没有日期，只需保留一个并删除其他重复项。

表格中的数据从第5行开始（不是图片中的第4行，对不起）。在过去，我知道当表格不是从第1行或第2行开始时，我在通过宏删除重复项时遇到了问题。

该表通常有大约15列和~10,000行。

有些行在P列中有日期，有些行没有。所以宏应该看看是否有任何重复（列A），如果是，检查列P中是否有日期。如果有更多重复日期，宏应该删除所有重复但保持最新。

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

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

问题：它保留第一行，而不是具有最新日期的那一行......

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

Answer 1

由于我在2013年办公室遇到了here和here面临的删除重复错误，因此线程与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

将日期从文本转换为日期，您可以录制此宏：
1.按Conf. Date从最新到最早分类 2.数据＆gt; Remove Duplicates＆gt;取消选中除REF列之外的所有内容 3.按REF列

排序

我认为使用数据透视表或PowerPivot会更容易，更灵活。

Answer 3

通常我会把所有这些都扔进一个Sub但你似乎喜欢@John Bustos解决方案。我曾经测试了一次它似乎工作让我知道如果我错过任何东西。

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

Excel VBA - 删除重复项并保留最新版本（基于日期列）

3 个答案: