Макрос для удаления дубликатов на основе одного столбца, затем переместите «старый» дубликат на другой лист

Question

У меня есть таблица с столбцами данных от A до H. Мне нужно удалить дубликаты на основе данных в столбце C. Простой.

Сложная часть заключается в том, что у меня есть дата в столбце 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, поэтому многие вещи могут быть неправильными. Я сохранил большую часть вашего кода, но в словаре (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