VBA重复值（不使用DV）

第一次发布，长时间堆栈冲浪。我有一个关于捕捉用户在工作表中输入重复值的问题。我们无法使用数据验证，因为剪切/复制/粘贴会抛出数据验证，并允许他们输入dupe值。我最初使用的代码是：

Option Explicit

Public Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

'******problem when copying entire row and pasting into new row, enables user to paste dupe Box ID #******

'Defining variables in Mailroom
Dim WS As Worksheet, EvalRange As Range

'Range to check for duplicates
Set EvalRange = Worksheets("Mailroom").Range("Box_ID_Number")

'Checking if entered value is in the defined range; also if cell is empty exit macro
If Intersect(Target, EvalRange) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub
If IsEmpty(Target) Then Exit Sub

'If user enters dupe value in specified range then error message pops up and event is undone
If WorksheetFunction.CountIf(EvalRange, Target.Value) > 1 Then
    MsgBox Target.Value & " already appears as a Box ID Number. Please enter a unique ID."
    Application.EnableEvents = False
    Application.Undo
    Application.EnableEvents = True
End If

End Sub

该代码可以很好地防止用户在“Box ID Number”列中键入重复值。我遇到的问题是，如果用户要从一列复制Box ID号，并从另一列复制另一个单元格，则他们可以粘贴一个重复值，而_SheetChange无法捕捉到该重复值。当我们第一次为此创建代码时，我们禁用了剪切/复制/粘贴功能；但是，其他使用该工作表的用户显然仍然需要该功能来处理工作表的其他部分

---

有什么想法吗

假设您的用户实际上一次只需要更改一个单元格，我认为下面的方法应该有效（这只是代码的底部部分）：

---

我删除了

或Target.Cells.Count>1

而不是

CountIf（EvalRange，Target.Value）

在我的版本中，您可以看到

CountIf（EvalRange，Intersect（Target，EvalRange））

。如果

Intersect（Target，EvalRange））

不是一个单元格，则会再次出现类型不匹配（13）错误。因此，为了防止它，我实施了您看到的附加检查。

@ZygD！用

Intersect（目标，EvalRange）

完成的代码如下所示：

Option Explicit

Public Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    'Defining variables in Mailroom
    Dim WS As Worksheet, EvalRange As Range

    'Range to check for duplicates
    Set EvalRange = Worksheets("Mailroom").Range("Box_ID_Number")

    If Intersect(Target, EvalRange) Is Nothing Then Exit Sub
    If IsEmpty(Target) Then Exit Sub

    'Check if only one cell in Box_ID_Number is changed at a time
    If Intersect(Target, EvalRange).Count > 1 Then
        MsgBox "Unable to modify greater than 1 Box ID Number at a time.  Please select one Box ID Row."
        Application.EnableEvents = False
        Application.Undo
        Application.EnableEvents = True
     Exit Sub
    End If`

    'check for dupe value in Box ID Number Column; if copy and pasting entire row, dupe check still holds
    If WorksheetFunction.CountIf(EvalRange, Intersect(Target, EvalRange)) > 1 Then
        MsgBox Intersect(Target, EvalRange) & " already appears as a Box ID Number. Please enter a unique ID."
        Application.EnableEvents = False
        Application.Undo
        Application.EnableEvents = True
    End If

End Sub

---

你需要。。。或Target.Cells.Count>1个零件？这就是粘贴两个或多个单元格时阻止函数捕获重复内容的原因。尝试删除“或Target.cells.Count>1”这会导致“类型不匹配”错误13，突出显示“If WorksheetFunction.CountIf（EvalRange，Target.Value）>1，然后”而不是使用

WorksheetFunction.CountIf

，尝试使用

sh.find（）

。如果生成的范围为Nothing，则为唯一值，否则为dupe。sh.find（）会给我一个“对象不支持此属性或方法”错误，因为您只关心一列，例如，

Set Target=Intersect（EvalRange，Target）

在设置了

EvalRange

并使用它之后，我非常喜欢你的逻辑。我尝试了您的代码，但当我仍尝试复制和粘贴多个单元格时，出现了一个错误。当我调试时，错误显示为“运行时错误'13:类型不匹配”，突出显示

MsgBox Target.Value&“已显示为框ID号。请输入唯一ID。”

尝试测试：而不是

Target.Value

使用

Intersect（Target，EvalRange）

。您也可以在主要问题下的注释中尝试建议。这看起来很有希望。

Option Explicit

Public Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    'Defining variables in Mailroom
    Dim WS As Worksheet, EvalRange As Range

    'Range to check for duplicates
    Set EvalRange = Worksheets("Mailroom").Range("Box_ID_Number")

    If Intersect(Target, EvalRange) Is Nothing Then Exit Sub
    If IsEmpty(Target) Then Exit Sub

    'Check if only one cell in Box_ID_Number is changed at a time
    If Intersect(Target, EvalRange).Count > 1 Then
        MsgBox "Unable to modify greater than 1 Box ID Number at a time.  Please select one Box ID Row."
        Application.EnableEvents = False
        Application.Undo
        Application.EnableEvents = True
     Exit Sub
    End If`

    'check for dupe value in Box ID Number Column; if copy and pasting entire row, dupe check still holds
    If WorksheetFunction.CountIf(EvalRange, Intersect(Target, EvalRange)) > 1 Then
        MsgBox Intersect(Target, EvalRange) & " already appears as a Box ID Number. Please enter a unique ID."
        Application.EnableEvents = False
        Application.Undo
        Application.EnableEvents = True
    End If

End Sub