删除重复的行，除了最后一次出现 – VBA Excel 2013

我需要微调我的代码删除除最后发生的所有重复。 重复将由多个列（列A，B，C）定义。 下一列总是有不同的数字，所以在定义重复项时会被忽略。 我需要删除整行。 另外过滤和单元格比较旁边的单元格将不起作用，因为那样它将不知道哪一个是最后发生的。 见示例表

Sub DuplicateDelete() Dim Rng As Range Dim Dn As Range Dim nRng As Range Dim Q As Variant Dim K As Variant With Sheets("Sheet1") Set Rng = .Range(.Range("A9:C9"), .Range("A" & Rows.Count).End(xlUp)) End With On Error Resume Next Rng.SpecialCells(xlCellTypeBlanks).Resize(, Columns.Count).Delete On Error GoTo 0 With CreateObject("scripting.dictionary") .CompareMode = vbTextCompare For Each Dn In Rng If Dn <> "" Then If Not .Exists(Dn.Value) Then .Add Dn.Value, Array(Nothing, Dn) Else Q = .Item(Dn.Value) If nRng Is Nothing Then Set Q(0) = Q(1) Set Q(1) = Dn Set nRng = Q(0) Else Set Q(0) = Q(1) Set nRng = Union(nRng, Q(0)) Set Q(1) = Dn End If .Item(Dn.Value) = Q End If End If Next If Not nRng Is Nothing Then nRng.EntireRow.Delete End If End With End Sub 

例如在上面的列表中，我需要删除顶部的2行，因为它们是最后2行的重复。 我只需要一个扫描仪，将扫描所有行，并决定删除除最后发生的所有重复。 可以吗？ 提前感谢您的帮助。

*注意：这不是我自己的代码，我是VBA的初学者级别，它是从search引用的。

Answer 1

1. 添加温度列
2. 填充编号系列的温度列
3. sorting温度列降序
4. 清除温度栏
5. 删除重复
6. 添加温度列
7. 填充编号系列的温度列
8. sorting温度列升序
9. 清除温度栏

---

 Sub RevRemoveDuplicates(SheetIndex As Integer, Optional FIRSTRANGE As String = "A9:J9") Application.ScreenUpdating = False Dim Target As Range, TempColumn As Range With Worksheets(SheetIndex) Set Target = .Range(FIRSTRANGE, .Range(FIRSTRANGE).End(xlDown)) Set TempColumn = Target.Offset(0, Target.Columns.Count).Resize(, 1) With TempColumn .Cells(1, 1).Value = 1 .DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False .EntireRow.Sort Key1:=.Cells(1, 1), Order1:=xlDescending .Clear End With Target.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo With TempColumn .Cells(1, 1).Value = 1 .DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False .EntireRow.Sort Key1:=.Cells(1, 1), Order1:=xlAscending .Clear End With End With Application.ScreenUpdating = True End Sub 

Answer 2

不知道我是否错过了一些明显的东西，但是不会从下往上循环，如果遇到已经遇到的值组合，那么删除那一行。

如果你使用了一个Collection你可以创build一个你的3个值的string键，例如“173 | 4566 | 3”，如果这个键已经存在，你就知道你有一个重复的。

另外，一次删除一行而不是一次删除行可能更快。

总而言之，你的代码可以是：

 Const START_ROW As Long = 9 Dim v As Variant Dim i As Long, r As Long Dim key As String Dim delRows As Range Dim uniques As Collection Dim exists As Boolean ' Read the values into an array With Sheet1 v = .Range(.Cells(START_ROW, "A"), _ .Cells(.Rows.Count, "A").End(xlUp)) _ .Resize(, 3).Value2 End With Set uniques = New Collection For i = UBound(v, 1) To 1 Step -1 key = CStr(v(i, 1)) & "|" & _ CStr(v(i, 2)) & "|" & _ CStr(v(i, 3)) exists = False 'Test if key exists On Error Resume Next exists = uniques(key) On Error GoTo 0 If exists Then 'we have a duplicate to be deleted r = i + START_ROW - 1 If delRows Is Nothing Then Set delRows = Sheet1.Cells(r, 1) Else Set delRows = Union(delRows, Sheet1.Cells(r, 1)) End If Else 'we have a new unique item uniques.Add True, key End If Next 'Delete the duplicate rows If Not delRows Is Nothing Then delRows.EntireRow.Delete End If 

Answer 3

非常感谢你的回答。 抱歉不能早日回复，昨天有点连接问题，所以自己尝试了一些东西。 我以略微不同的方式结束了类似的逻辑。 把数据表完全颠倒过来，然后使用内置的“删除重复”function，然后再将数据翻回来。 这让我保持最后的发生，因为我想要的。

这是每个工作簿的循环function。

 Function Dup_removal_Repeat_all_sheets(i) 'first flip data tables upside down, as excel's duplicate delete works 'only downwards, but we want to keep latest duplicate addition Dim vTop As Variant Dim vEnd As Variant Dim iStart As Integer Dim iEnd As Integer Sheets(i).Select Range("A10:J10").Select Range(Selection, Selection.End(xlDown)).Select Application.ScreenUpdating = False iStart = 1 iEnd = Selection.Rows.Count Do While iStart < iEnd vTop = Selection.Rows(iStart) vEnd = Selection.Rows(iEnd) Selection.Rows(iEnd) = vTop Selection.Rows(iStart) = vEnd iStart = iStart + 1 iEnd = iEnd - 1 Loop Application.ScreenUpdating = False 'Now scan top to bottom to delete duplicates Range("A10:J10").Select Range(Selection, Selection.End(xlDown)).Select ActiveSheet.Range("$A$10:$J$2000").RemoveDuplicates Columns:=Array(1, 2, 3), _ Header:=xlNo 'Flip data tables back Range("A10:J10").Select Range(Selection, Selection.End(xlDown)).Select Application.ScreenUpdating = False iStart = 1 iEnd = Selection.Rows.Count Do While iStart < iEnd vTop = Selection.Rows(iStart) vEnd = Selection.Rows(iEnd) Selection.Rows(iEnd) = vTop Selection.Rows(iStart) = vEnd iStart = iStart + 1 iEnd = iEnd - 1 Loop Application.ScreenUpdating = True End Function 

唯一的问题是，它将擦除所有表格单元格中的公式，我所做的解决方法是从进程（第9行）中排除第1行，然后在进程结束时自动填充到最后一行数据，在所有列。 而对于重复的扫描，我给了2000行的任意值（这不会是大事，但不必在将来编辑它）。