用第一个重复行中的最后一个重复替换第一个重复 - Excel VBA

Question

简单地说，对于这个项目，我想删除重复项，保留重复项的最新条目，并在第一个条目行中替换这些最新条目。请按照下面给出的示例更好地理解：

我希望通过保留从 A 列到 C 列的最新条目来删除基于 ID 号的重复项。此外，我希望保留 D 列和 E 列中的每个单元格从第一个条目中。这最终意味着最新的条目将被替换在第一个条目的 A、B 和 C 列中。

重要提示：D & E 栏将只填写每个 ID 的第一个条目。具有相同 ID 的所有其他行将始终在 D 和 E 列中包含空单元格。

请参阅下表以获得更清晰的信息，其中反映了上述解释：

根据上面给出的例子，这意味着：

• 根据 ID 从 A 到 C 列删除重复项并保留每个 ID 的最新条目（从 A 列到 C 列：删除第 1、2、3、5 和 6 行中的内容 + 保留每个 ID 的最新条目在这种情况下是第 4 行和第 7 行）

• 保留每个 ID 的第一个条目中的 D 和 E 列（请注意，只有每个 ID 的第一个条目将是非空单元格。在此示例中，有两个 ID，123 和 458，并且只有D & E 列的第 1 行和第 2 行将是非空的）

• 将之前的条目替换为从 A 列到 C 列的先前条目行中的最新条目（从 A 列到 C 列，分别将第 1 行和第 2 行替换为第 4 行和第 7 行）

换句话说：在不修改 D 列到 E 的情况下更新 A 列到 C 列

请参阅下面的相同表格和指示：

我尝试了两种不同的代码，但都没有给出我想要的最终结果。

所以，我的初始代码如下。它只保留以前的条目，并保持 A 到 E 列的初始状态：

Sub Delete_Duplicates()
    Sheet5.Range("$A$1:$E$29999").RemoveDuplicates Columns:=Array(1) _
    , Header:=xlYes
End Sub  

最终结果不准确，因为它保留了 A 到 C 列中的第一个条目：

上面代码中的问题是它没有将名称和日期更改为最新条目（分别是 Bob，第 6 周和 Peter，第 4 周）

我做的下一个代码是保留最新的条目，但不幸的是，这会删除我在 D 到 E 列中的条目：

Sub Delete_Duplicates_2()
Dim Rng As Range, Dn As Range, n As Long
Dim Lst As Long, nRng As Range
Set Rng = Sheet5.Range("$A$2:$E$29999")
Lst = Range("A" & Rows.Count).End(xlUp).Row
    With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
    For n = Lst To 1 Step -1
    If Not .Exists(Range("A" & n).Value) Then
    .Add Range("A" & n).Value, Nothing
    Else
        If nRng Is Nothing Then
            Set nRng = Range("A" & n)
        Else
            Set nRng = Union(nRng, Range("A" & n))
        End If
    End If
    Next n
    If Not nRng Is Nothing Then 
    nRng.EntireRow.Delete
    End With
End Sub

以下是我从第二个代码中获得的结果：

上面的代码可以完美地用最新的条目替换我的第一个条目，但它会删除 D 和 E 列（评论和附加 com）中的所有内容。我想知道是否可以通过仅替换特定列中的重复项而不是删除整行来修改我的代码（这显然是此代码中的问题）。

我希望你的解释足够清楚，可以帮助我解决这个问题。请记住，我有数千行，而针对我给出的示例量身定制的解决方案并不是我想要的。我愿意接受任何建议，感谢您的帮助！

Answer 1

此例程使用字典对象来删除重复项。

为了保留副本的最后一行，我们从底部开始向上工作。

如果确实有重复，我们测试看看第 4 列或第 5 列中是否有任何内容，如果有，我们将覆盖字典中的内容（注意数组项不能直接更改，但我们必须提取数组，修改它，然后放回去。

然后我们创建一个结果数组并将其写回工作表。

明智地选择wsRes、wsSrc 和rRes 将允许您在单独的工作表中获得结果，甚至覆盖原始数据（尽管出于审计目的我不建议这样做）。

请注意，您必须按照代码的 cmets 中的说明设置引用，或者使用后期绑定。

Option Explicit
'Set reference to Microsoft Scripting Runtime or
'    use late-binding
Sub deDup()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim vRow(2 To 5) As Variant, vKey As Variant, vTemp As Variant
    Dim I  As Long, J As Long
    Dim D As Dictionary

 Set wsSrc = Worksheets("sheet3")
 Set wsRes = Worksheets("Sheet3")
    Set rRes = wsRes.Cells(1, 9)

With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=5)
End With

Set D = New Dictionary
For I = UBound(vSrc, 1) To 2 Step -1
    vKey = vSrc(I, 1)
    If Not D.Exists(vKey) Then
        For J = 2 To 5
            vRow(J) = vSrc(I, J)
        Next J
        D.Add Key:=vKey, Item:=vRow
    Else
        If vSrc(I, 4) <> "" Or vSrc(I, 5) <> "" Then
            vTemp = D(vKey)
            vTemp(4) = vSrc(I, 4)
            vTemp(5) = vSrc(I, 5)
            D(vKey) = vTemp
        End If
    End If
Next I

ReDim vRes(0 To D.Count, 1 To 5)

    'Headers
    For J = 1 To 5
        vRes(0, J) = vSrc(1, J)
    Next J

    'Data
    I = 0
    For Each vKey In D.Keys
        I = I + 1
        vRes(I, 1) = vKey
        For J = 2 To 5
            vRes(I, J) = D(vKey)(J)
        Next J
    Next vKey

Set rRes = rRes.Resize(rowsize:=D.Count + 1, columnsize:=UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With
End Sub

Answer 2

我的数据如下（A 列 ID、B 列名称、C 列数据）

A       B       C

1   a   Last

1   a   

2   b   pre

2   b   

3   c   test

3   c   test2

3   c   

3   c

如果您获得唯一 ID 并将它们放在一列中，请使用 VBA 或公式。

然后您可以在 VBA 中使用 evaluate 从数据中获取最后一个值，就像这样

evaluate("INDEX($C$1:$C$8,MAX(($A$1:$A$8=F1)*($C$1:$C$8<>"""")*ROW($A$1:$A$8)),1)")

其中 F 列是唯一的 ID 号。

这假设数据是按时间顺序排列的。