CODEWITHSUNDEEP
vbaexcel
Andy Dufresne
Andy Dufresne

Reputation: 25

Remove duplicates based on one column, then move the "older" duplicate to another sheet

I have a spreadsheet with data columns A through H. I need to remove duplicates based on data in column C.

The tricky part is that I have a date in column E. I need the "older" duplicate to be moved to another sheet, not deleted.

I have a macro to move duplicates to another sheet, but it's selection on what stays/goes is random.

Requested edit: It's not that this macro is wrong, it's that I don't know how to make it move the older duplicate based on date in column 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

Upvotes: 1

Views: 454

Answers (1)

CMArg
CMArg

Reputation: 1567

Try the following. First of all, I'm no at all a VBA guru, so many things might be wrong. I kept most of your code, but in the Dictionary(d), I'm adding not only the value, but also an Array with the row number and the value in column E. In this way, when the loop reaches a cell that is already in the dictionary, instead of skipping it you can test the two ColumnE values, and decides which one to keep.

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

Upvotes: 1

Related Questions