Force pasted values to obey data validation rules

Question

I have a (simplified example) matrix consisting of inputs and alarms. Each action (X) should have an input and an alarm i.e. no actions should be inserted in column E or row 6.

I used data validation to implement this and it works.

However if I paste data to these cells they do not follow the validation rules. I inserted this VBA code to prevent this (extracted from 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

However, this code also prevents values from being pasted into cells even when they do not break validation rules e.g. if I paste an X to input a;alarm 1, I get an error message. Is there any way to prevent values from being pasted only when they break validation rules?

Edit:

I have altered the code to:

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

This now circles invalid cells and produces a msg box if one is found. This is done based on the fact that the invalid circle is a shape. I can get the code to work by searching the whole sheet but I am trying to narrow the search to a specified range. However I get the error "1004 - Application-defined or object-defined error" due to shp.TopLeftCell. Any ideas?

Solution

Decided not to go down the shape route and instead search for validation values:

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