Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Dim rng2 As Range
Dim isect As Range
Dim isect2 As Range
Dim cell As Range
Dim dd() As Variant
Dim i As Long
Dim mtch As Boolean
Dim msg As String
Dim myEntries As String
Dim ddRange As Range
'***Set column E validation range
Set rng1 = Range("E7:E12")
'***Set column A validation range
Set rng2 = Range("A1:A100")
'***Set drop-down list value range
Set ddRange = Sheets("Sheet1").Range("A1:A3")
' See if any updated cells fall in column E range
Set isect = Intersect(rng1, Target)
' See if any updated cells fall in column A range
Set isect2 = Intersect(rng2, Target)
' Exit if updated cells do not fall in either validation range
If (isect Is Nothing) And (isect2 Is Nothing) Then Exit Sub
Application.EnableEvents = False
' First check (column E)
If Not isect Is Nothing Then
' Build array of drop-down values
ReDim dd(ddRange.Cells.Count)
i = 0
For Each cell In ddRange
dd(i) = cell.Value
i = i + 1
Next cell
' Loop through all intersecting cells
For Each cell In isect
' See if cell entry matches any drop-down values
mtch = False
For i = LBound(dd) To UBound(dd)
If cell.Value = dd(i) Then
mtch = True
Exit For
End If
Next i
' If value is not in list, erase and return message
If mtch = False Then
cell.ClearContents
msg = msg & cell.Address(0, 0) & ","
End If
Next cell
' Build string of validation entries
For i = LBound(dd) To UBound(dd)
myEntries = myEntries & dd(i) & ","
Next i
myEntries = Left(myEntries, Len(myEntries) - 1)
' Reset validation
With rng1.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=myEntries
End With
' Return message, if necessary
If Len(msg) > 0 Then
MsgBox "Invalid entries in cells: " & vbCrLf & Left(msg, Len(msg) - 1), vbOKOnly, "ERROR!"
End If
End If
' Second check (column A)
If Not isect2 Is Nothing Then
' Loop through all intersecting cells
For Each cell In isect2
If (Len(cell) > 0) And (Len(cell) <> 11) Then
cell.ClearContents
msg = msg & cell.Address(0, 0) & ","
End If
Next cell
' Reset validation
With rng2.Validation
.Delete
.Add Type:=xlValidateTextLength, AlertStyle:=xlValidAlertStop, _
Operator:=xlEqual, Formula1:="11"
End With
' Return message, if necessary
If Len(msg) > 0 Then
MsgBox "Invalid entries in cells: " & vbCrLf & Left(msg, Len(msg) - 1), vbOKOnly, "ERROR!"
End If
End If
Application.EnableEvents = True
End Sub
