excel - 强制粘贴的值遵守数据验证规则

Question

我有一个由输入和警报组成的(简化示例)矩阵。每个操作 (X) 都应该有一个输入和一个警报，即不应在 E 列或第 6 行中插入任何操作。

我使用数据验证来实现这一点并且它有效。

但是，如果我将数据粘贴到这些单元格，它们将不遵循验证规则。我插入了此 VBA 代码来防止出现这种情况(摘自 www.j-walk.com/ss/excel/tips/tip98.htm):

Private Sub Worksheet_Change(ByVal Target As Range)
    'Does the validation range still have validation?
    If HasValidation(Range("ValidationRange")) Then
        Exit Sub
    Else
       Application.EnableEvents = False
       Application.Undo
        MsgBox "Your last operation was canceled." & _
        " It would have deleted data validation rules.", vbCritical
    End If
End Sub

Private Function HasValidation(r) As Boolean
'   Returns True if every cell in Range r uses Data Validation
    On Error Resume Next
    x = r.Validation.Type
    If Err.Number = 0 Then HasValidation = True Else HasValidation = False
End Function

但是，此代码还可以防止将值粘贴到单元格中，即使它们没有违反验证规则，例如如果我粘贴 X 来输入 a;alarm 1，我会收到一条错误消息。有什么方法可以防止仅在违反验证规则时才粘贴值吗？

编辑:

我已将代码更改为:

Private Sub Worksheet_Change(ByVal Target As Range)

With Range("D4:H8").Validation
        .Delete
        .Add Type:=xlValidateCustom, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=OR(ISBLANK(D4),AND(NOT(ISBLANK($C4)),NOT(ISBLANK(D$3))))"
        .IgnoreBlank = False
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = "Stop"
        .InputMessage = ""
        .ErrorMessage = "Actions Must Have Input and Output"
        .ShowInput = True
        .ShowError = True
    End With

Me.CircleInvalid

Count = 0
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
    If Not Intersect(shp.TopLeftCell, Range("D4:H8")) Is Nothing Then Count = Count + 1
Next

If Count > 0 Then
MsgBox "Actions Must Have Input and Output"
End If

End Sub

现在，这会圈出无效单元格，如果找到，则会生成一个消息框。这是基于无效圆是形状的事实来完成的。我可以通过搜索整个工作表来使代码正常工作，但我试图将搜索范围缩小到指定范围。但是，由于 shp.TopLeftCell，我收到错误“1004 - 应用程序定义或对象定义错误”。有什么想法吗？

Answer 1

决定不走形状路线，而是搜索验证值:

Dim Cell As Range
For Each Cell In Range("D4:H8")
    If Not Cell.Validation.Value Then
        MsgBox "Actions Should Have Input and Output"
        Exit Sub
    End If
Next