Beriech anpassen

Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.Unprotect Password:="******"
Application.EnableEvents = False
ValError = False
On Error GoTo Ende
Set Bereich = Nothing
For Each x In Target.Cells
If x.Validation.Value = False Then
If Bereich Is Nothing Then Set Bereich = x Else Set Bereich = Union(Bereich, x)
ValError = True
msg = msg + " " + x.Address + " "
End If
Next
Bereich.ClearContents
If ValError Then MsgBox "The added values have hurt the validity of the following cells: _
" & msg
Ende:
Application.EnableEvents = True
ActiveSheet.Protect Password:="******", AllowFormattingColumns:=True, AllowFiltering:=True
End Sub