Sub EintragenUndSperren()
Dim rng As Range, x As Range, Val&
Set rng = Range("A1:C10")
For Each x In rng
Val = (Val + 1) + (Rnd * 1000)
x = Val
With x.Validation
.Delete
.Add Type:=xlValidateWholeNumber, AlertStyle:=xlValidAlertStop, _
Operator:=xlEqual, Formula1:=Val
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = "Eingabemeldung Titel"
.ErrorTitle = "Fehlermeldung Titel..."
.InputMessage = "Eine Eingabemeldung"
.ErrorMessage = "Eine Fehlermeldung..."
.ShowInput = True
.ShowError = True
End With
Next
End Sub