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

感谢K.Davis的帮助。感谢您的辛勤工作。

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

Worksheet_Change事件-重复检查，忽略空格

2 个答案: