根据条件删除列中的重复项

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