Событие Worksheet_Change - проверка дублирования, игнорирование пробелов

Question

Я использую событие изменения VBA для поиска дубликатов в столбце C. Приведенный ниже код работает, но когда я удаляю все значения в пределах диапазона, пробелы запускаются как дубликаты, поэтому мне нужно включить способ игнорировать дубликаты из кода , Есть идеи?

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cell As Range

    On Error GoTo ws_exit

    Application.EnableEvents = False

    With Target

        If .Column = 3 Then

            With .EntireColumn

                Set cell = .Find(What:=Target.Value, AFter:=.Cells(1, 1))
                If cell.Address = Target.Address Then

                    Set cell = .FindNext()
                End If

                If Not cell.Address = Target.Address Then

                    MsgBox "This Wall Reference already exists. Please ensure you have a unique reference identifier less than 20 characters in length", vbOKOnly
                End If
            End With
        End If
    End With

    ws_exit:
    Application.EnableEvents = True
End Sub

Я ожидаю, что смогу игнорировать пропуски, но, тем не менее, VBA выполнит проверку дублирования, чтобы вернуть msgbox, только если дублирование найдено.

Answer 1

Прежде всего, вы должны учитывать, что Target - это диапазон нескольких ячеек, а не только одной ячейки. Поэтому необходимо использовать Intersect, чтобы получить все ячейки, которые были изменены в столбце 3, а затем вам нужно пройти через эти ячейки, чтобы проверить каждую из них.

Также я рекомендую использовать WorksheetFunction.CountIf, чтобы подсчитать, как часто это значение встречается, если оно равно >1, то оно является дубликатом. Это должно быть быстрее, чем при использовании Find.

Обратите внимание, что следующий код ищет дубликаты в столбце 3, только если вы хотите проверить, существует ли дубликат где-либо на листе, замените CountIf(Me.Columns(3), Cell.Value) на CountIf(Me.Cells, Cell.Value)

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim AffectedRange As Range
    Set AffectedRange = Intersect(Target, Me.Columns(3))

    If Not AffectedRange Is Nothing Then
        Dim Cell As Range
        For Each Cell In AffectedRange

            If Application.WorksheetFunction.CountIf(Me.Columns(3), Cell.Value) > 1 Then
                MsgBox "This Wall Reference already exists. Please ensure you have a unique reference identifier less than 20 characters in length", vbOKOnly + vbExclamation
            End If

        Next Cell
    End If

End Sub

Вместо использования VBA вы также можете использовать условное форматирование, например, чтобы выделить дубликаты красным цветом. Может быть проще архивировать (используйте формулу =CountIf в качестве условия). Кроме того, он всегда сразу выделяет все дубликаты, что облегчает их определение.

Answer 2

Спасибо за помощь К.Дэвис.Я ценю ваше время и усилия.

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Value = vbNullString Then Exit Sub
    Dim cell As Range

    On Error GoTo ws_exit

    Application.EnableEvents = False

    With Target

    If .Column = 3 Then

    With .EntireColumn

    Set cell = .Find(What:=Target.Value, AFter:=.Cells(1, 1))
    If cell.Address = Target.Address Then

    Set cell = .FindNext()
    End If

    If Not cell.Address = Target.Address Then

    MsgBox "This Glazing Reference already exists. Please ensure you have a unique reference identifier less than 20 characters in length", vbOKOnly
    End If
    End With
    End If
    End With

    ws_exit:
    Application.EnableEvents = True
End Sub