Удалить дубликаты в столбце на основе условия

Question

Я не могу получить следующий код: у меня есть таблица с 2 столбцами.В первом столбце хранится имя элемента (2 возможных имени: «Книга» и «Клавиатура»), а в столбце 2 - номера.Я хочу написать код, в соответствии с которым, если в столбце 2 вдоль обоих возможных имен элементов присутствуют одинаковые номера, тогда должно доминировать имя элемента «Клавиатура», а все номера в столбце 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 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, я бы использовал вспомогательный столбец и пару 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

Попробуйте, у меня все работает.Кажется, вы должны включить верхнюю строку, иначе она игнорирует первое значение.И вы должны удалить дубликаты для книг, а не клавиатуры.

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