エクセルVBA - 重複を削除し、（日付列に基づく）最新に保つ

Question

誰かが私を助けることができますか？私はどのように起動するのかわかりません... （列Aに基づいて）重複を削除し、最新の日付（列P）を持つ行を保持するマクロを作成したいと思います。そして、すべての重複列に列Pの日付がない場合は、1つを保持して他の重複を削除します。

行5有するシート開始のデータ（そのため申し訳ありませんが、画像のように4行ではありません）。過去に私はテーブルが〜10.000行を〜行1または2

表は通常の周りに持っていると15列を起動していないとき、私はマクロを経由して、重複を削除して問題を抱えていたことを知っています。

行の一部

は、列Pの日付を持っており、いくつかの行にはありません。そのため、重複する列（列A）があるかどうかを確認する必要があります。そうであれば、列Pに日付があるかどうかを確認します。日付が重複する場合、マクロはすべての重複を削除します。

TL ...それは最初の行ではなく、最新の日付のものを保持します; DR：

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 

問題：

コードは、私がこれまでに編集/使用重複をチェックしますAで日付を確認した後、すべての重複を削除しますが、最新のものを保存してください。日付がない場合は、すべての重複を削除してください。

Answer 1

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

：最古にnewestからConf. Dateによって
1.ソートを私が今までこの機能に依存しない、代わりに、私はこれをコード化
2.データ>Remove Duplicates>すべてが、私は、これは簡単かつ柔軟ウィットになると思いますREF列

---

によってREF列
3.ソートのチェックを外しますピボットテーブルまたはPowerPivot。

Answer 3

通常、私はただ一つのサブにこのすべてを投げるだろうが、あなたは@ジョン・ブストスソリューションを好むように見えました。私はこれを一度試してみたところ、何かを見逃してしまったかどうか私に知らせてくれたようでした。

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