刪除重複的行，除了最後一次發生 - VBA Excel 2013

Question

我需要微調我的代碼以刪除除最後發生的所有重複項。重複將由多列（列A，B，C）定義。下一列總是有不同的數字，因此在定義重複項時會被忽略。我需要刪除整行。在單元格比較旁邊過濾和執行單元格也不起作用，因爲那樣它就不知道最後一次發生哪一個單元。 See example table

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行。我只需要一臺能夠掃描所有行的掃描儀，並決定刪除除最後一次出現以外的所有重複項。有可能嗎？提前感謝您的幫助。

*注意：這不是我自己的代碼，我是VBA的初學者級別，它是從搜索引用的。

Answer 1

1. 添加temp欄
2. 填充temp欄用數字系列
3. 排序temp欄降序
4. 清除temp欄
5. 刪除重複項
6. 添加溫度欄
7. 填充temp欄用數字系列
8. 排序temp欄升序
9. 清除temp欄

---

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，則可以創建3個值的字符串鍵，例如「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 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 

這個唯一的問題，它會清除公式中的所有表格單元格，解決方法我所做的是從過程中排除第1行（第9行），然後在過程結束時，自動填充它歸結爲最後一行數據，在所有列中。對於重複掃描，我給出了2000行的任意值（這不是大小寫，但是將來不需要編輯它）。