Question

我有一个包含数据列A到H的电子表格。我需要根据C列中的数据删除重复项。

棘手的部分是我在E栏中有一个约会。我需要年龄较大的＆＃34;复制将移动到另一个工作表，而不是删除。

我有一个宏可以将重复项移到另一个工作表，但它选择停留/去往的是随机的。

请求编辑：并不是说这个宏是错误的，我不知道如何根据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

根据一列删除重复项，然后移动＆＃34; old＆＃34;复制到另一张纸

1 个答案: