VBA重复值（不使用DV）

第一时间发帖，长时间堆栈冲浪。 我有一个关于捕获用户在工作表中inputdupe值的问题。 我们无法使用数据validation，因为剪切/复制/粘贴抛出数据validation，并允许他们input重复值。 我最初使用这个代码：

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”列中input一个dupe值。 我遇到的问题是，如果用户要从一个列中复制一个Box ID号码，并从另一个列中复制另一个单元格，则他们可以粘贴_SheetChange不能捕获的Dupe值。 当我们第一次为此创build代码时，我们禁用了剪切/复制/粘贴function; 然而，使用纸张的其他人显然仍然需要该纸张的其他部分的function。

有任何想法吗？

Answer 1

假设你的用户一次只需要改变一个单元格，我认为下面的东西应该可以工作（它只是你的代码的底部）：

 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 If Intersect(Target, EvalRange).Count > 1 Then MsgBox "One cell at a once please." Application.EnableEvents = False Application.Undo Application.EnableEvents = True Exit Sub End If If WorksheetFunction.CountIf(EvalRange, Intersect(Target, EvalRange)) > 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 

我已经删除Or Target.Cells.Count > 1而不是CountIf(EvalRange, Target.Value)在我的版本中你看到CountIf(EvalRange, Intersect(Target, EvalRange)) 。 如果Intersect(Target, EvalRange))不是一个单元格，您将再次获得types不匹配（13）错误。 因此，为了防止它，我已经实施了你看到的额外的检查。

Answer 2

@ZygD！ 钉与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