Проверьте Дубликаты в столбце и выделите его

Question

Мне нужно проверить дубликаты в column B Я пишу следующий код, который кажется правильным, но вместо этого я получаю Run time Error 13 type-mismatch, пожалуйста, помогите. почему я получаю его?

Sub duplicate()
    Dim myRange As Range
    Dim myCell As Range

    Set myRange = Columns("B:B")
    For Each myCell In myRange
        If WorksheetFunction.CountIf(myRange, myCell.Value) > 1 Then ' Run-time error 13 Type mismatch
            myCell.Interior.ColorIndex = 3
        End If
    Next myCell
End Sub

Обновление: Для получения дополнительной информации следуйте https://www.youtube.com/watch?v=drZK_-zzo_4

Answer 1

Вам не нужен VBA для цветных дубликатов. Просто используйте условное форматирование:

Но только для вашего интереса, что вызвало ошибку в вашем коде, это то, что если вы l oop

For Each myCell In myRange

Вы на самом деле не oop через клетки в myRange, а через столбцы myRange, который только один (столбец B). Если вы хотите l oop через ячейки myRange, вам нужно изменить его на

For Each myCell In myRange.Cells

, в противном случае myCell.Value - это массив значений столбца B и, следовательно, WorksheetFunction.CountIf(myRange, myCell.Value) не удалось.

---

Если вам действительно нужно использовать VBA, я настоятельно рекомендую создавать условное форматирование с помощью VBA вместо вашего кода. Это будет намного быстрее, ваш код будет чрезвычайно медленным .

Option Explicit

Public Sub CreateRuleForDuplicates()
    Dim MyRange As Range
    Set MyRange = Columns("B:B")
    With MyRange
        .FormatConditions.AddUniqueValues
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        .FormatConditions(1).DupeUnique = xlDuplicate
        .FormatConditions(1).Interior.ColorIndex = 3
        .FormatConditions(1).StopIfTrue = False
    End With
End Sub

Обратите внимание, что если вы запускаете код несколько раз, он будет добавлять новое правило каждый раз , Поэтому вы можете удалить все старые правила в этом диапазоне .FormatConditions.Delete перед добавлением нового .AddUniqueValues.