根據條件刪除列中的重復項

Question

我無法執行以下代碼：我有一個包含2列的表。 第一列存儲項目名稱（2個可能的名稱：“ Book”和“ Keyboard”），第二列存儲數字。 我要編寫代碼，根據該代碼，如果第2列中兩個可能的商品名稱都包含理想數字，則商品名稱“鍵盤”應占主導地位，而第2列中沿名稱“ Book”的所有數字應刪除。

這是運行代碼之前的情況：

這是我想要的結果：

我正在嘗試使用下面的代碼，但無法正常工作。 我也不確定是否不應該使用其他過程，如數組？

Sub RemoveDuplicate()

 Dim ws1 As Worksheet
 Set ws1 = Sheets("Sheet1")
 Dim cell As Range
 Dim rng_delete As Range
 Dim rng_Item As Range
 Dim LastRow As Integer

With ws1
    LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    Set rng_delete = .Range(.Cells(3, 1), .Cells(LastRow, 2))
    Set rng_Item = .Range(.Cells(3, 1), .Cells(LastRow, 1))


        For Each cell In rng_Item
            If cell.Value <> "Keyboard" Then
                rng_delete.RemoveDuplicates Columns:=2, Header:=xlYes
            End If
        Next cell
End With

End Sub

我將不勝感激任何幫助。

Answer 1

根據您的評論以及您希望保留Number的重復Item （只要這些重復項是Keyboard in Item中的Keyboard ），我將使用一個幫助器列和幾個自動AutoFilters來定義要刪除的范圍。 我通過重新創建您的數據進行了測試。

Sub DeleteSpecificDuplicates()
    Dim endrow As Long
    Dim dRng As Range
    With ThisWorkbook.Worksheets("Sheet1")
        endrow = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("C2") = "tempCount"
        .Range("C3").Formula = "=COUNTIF(" & .Range("B3:B" & endrow).Address & ",B3)"
        .Range("C3:C" & endrow).FillDown
        With .Range("A2:C" & endrow)
            .AutoFilter Field:=1, Criteria1:="<>Keyboard"
            .AutoFilter Field:=3, Criteria1:=">1"
        End With
        If WorksheetFunction.Subtotal(3, .Range("A3:A" & endrow)) > 0 Then
            Set dRng = .Range("A3:C" & endrow).SpecialCells(xlCellTypeVisible)
            .AutoFilterMode = False
            dRng.Delete Shift:=xlUp
        End If
        If .AutoFilterMode = True Then .AutoFilterMode = False
        .Columns(3).ClearContents
    End With
End Sub

這將定義一個范圍，其中Item <> Keyboard且Number出現的次數>1 ，然后刪除該指定范圍。

Answer 2

試試這個，對我有用。 似乎您必須包括第一行，否則它將忽略第一個值。 而且您必須刪除書籍而不是鍵盤的重復項。

子RemoveDuplicate（）

 Dim ws1 As Worksheet
 Set ws1 = Sheets("Sheet1")
 Dim cell As Range
 Dim rng_delete As Range
 Dim rng_Item As Range
 Dim LastRow As Long

With ws1
    LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

    Set rng_delete = .Range(.Cells(1, 1), .Cells(LastRow, 2))
    Set rng_Item = .Range(.Cells(1, 1), .Cells(LastRow, 1))


        For Each cell In rng_Item
            If cell.Value <> "Book" Then
                rng_delete.RemoveDuplicates Columns:=2, Header:=xlYes
            End If
        Next cell
End With


End Sub