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

Question

我无法执行以下代码： 我有2列的表格。第一列存储项目名称（2个可能的名称：“ Book”和“ Keyboard”），第二列存储数字。 我要编写代码，根据该代码，如果第2列中两个可能的商品名称中都包含数字，则商品名称“ Keyboard”应占主导地位，而第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的重复项（只要这些重复项是Keyboard中的Item），我将使用帮助器列和几个{{1}定义要删除的范围。我对您的数据进行了重新测试。

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，然后删除该指定范围。

Answer 2

尝试一下，它对我有用。似乎您必须包括第一行，否则它将忽略第一个值。而且您必须删除书籍而不是键盘的重复项。

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 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