宏刪除基於一列的重複項，然後將「較舊」的副本移動到另一個工作表

Question

我有一個電子表格，數據列A到H.我需要刪除基於C列數據的重複項。

棘手的部分是，我在E列中有一個日期。我需要將「較舊」的副本移動到另一個工作表，而不是刪除。我有一個宏將重複項移動到另一個工作表，但它選擇什麼停留/隨機是隨機的。

如果我需要詳細說明，請告訴我！

要求編輯：這並不是說這個宏是錯誤的，那就是我不知道如何使它移動基於日期前輩重複列E.

Sub DupMove() 
Dim t As Single 
Dim d As Object, x&, xcol As String 
Dim lc&, lr&, k(), e As Range 
xcol = "C" 
lc = Cells.Find("*", after:=[a1], searchdirection:=xlPrevious).Column 
lr = Cells.Find("*", after:=[a1], searchdirection:=xlPrevious).Row 
ReDim k(1 To lr, 1 To 1) 
Set d = CreateObject("scripting.dictionary") 
For Each e In Cells(1, xcol).Resize(lr) 
    If Not d.exists(e.Value) Then 
     d(e.Value) = 1 
     k(e.Row, 1) = 1 
    End If 
Next e 
Cells(1, lc + 1).Resize(lr) = k 
Range("A1", Cells(lr, lc + 1)).Sort Cells(1, lc + 1), 1 
x = Cells(1, lc + 1).End(4).Row 
Cells(x + 1, 1).Resize(lr - x, lc).Copy Sheets("Duplicates").Range("A1") 
Cells(x + 1, 1).Resize(lr - x, lc).Clear 
Cells(1, lc + 1).Resize(x).Clear 

End Sub 

Answer 1

嘗試以下。首先，我完全不是一個VBA大師，很多事情可能是錯誤的。我保留了大部分代碼，但是在Dictionary中（d），我不僅添加了值，還添加了一個包含行號和列E中的值的數組。通過這種方式，當循環到達一個單元格時已經在字典中，而不是跳過它，您可以測試兩個ColumnE值，並決定保留哪一個。

Sub DupMove() 
    Dim t As Single 
    Dim d As Object, x&, xcol As String 
    Dim lc&, lr&, k(), e As Range 
    xcol = "C" 
    lc = Cells.Find("*", after:=[a1], searchdirection:=xlPrevious).Column 
    lr = Cells.Find("*", after:=[a1], searchdirection:=xlPrevious).Row 
    ReDim k(1 To lr, 1 To 1) 
    Set d = CreateObject("scripting.dictionary") 
    For Each e In Cells(1, xcol).Resize(lr) 
     If Not d.exists(e.Value) Then 'If not in dictionary, add it 
      d.Add e.Value, Array(Cells(e.Row, 5), e.Row) 'Add the value, and an Array with column E (5) data and number of row 
      k(e.Row, 1) = 1 
     Else       'If already in dictionary, test the new column E value with that saved in the array 
      If d(e.Value)(0).Value < Cells(e.Row, 5).Value Then 
       k(d(e.Value)(1), 1) = "" 
       k(e.Row, 1) = 1 
       d(e.Value)(0) = Cells(e.Row, 5) 
       d(e.Value)(1) = e.Row 
      End If 

     End If 
    Next e 

    Cells(1, lc + 1).Resize(lr) = k 
    Range("A1", Cells(lr, lc + 1)).Sort Cells(1, lc + 1), 1 
    x = Cells(1, lc + 1).End(4).Row 
    Cells(x + 1, 1).Resize(lr - x, lc).Copy Sheets("Duplicates").Range("A1") 
    Cells(x + 1, 1).Resize(lr - x, lc).Clear 
    Cells(1, lc + 1).Resize(x).Clear 

End Sub