Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Rem so allgemein wie möglich, daher
Rem die Spalte wo "Validation-Objekt" variabel
Dim clOffset As Long
Rem es ändert sich fallweise nur die Formel1 für das o.g. Objekt, daher
Dim strFormula1 As String
Rem Mehrfachselektionen durch den Benutzer sind nicht erlaubt, daher
If Target.Count > 1 Then Exit Sub
Rem die Titelzeilen sind gesperrt, daher
If Target.row < 6 Then Exit Sub
Rem jetzt die Fallunterscheidung nach Spalte
Select Case Target.column
Case 3
strFormula1 = "=Drivers"
Case 5
strFormula1 = "=Category"
Case 6
Exit Sub
Case 10
strFormula1 = "=Organizational_level"
Case Else
Exit Sub
End Select
Rem alle Objekte sind 1 rechts von
clOffset = 1
Rem die Arbeit macht die Funktion und wenns nicht kracht, dann
Rem soll der Benutzer ja die zugehörige Auswahl treffen, denn
Rem die Excel Voreinstellung ist nie zwingend xlToRight
If ChkValidation(Len(Trim(Target.Formula)), Target.Offset(0, clOffset), _
3, 1, 1, strFormula1) Then Target.Offset(0, clOffset).Select
End Sub
Private Function ChkValidation(tLen As Long, vCell As Range, _
vlType As XlDVType, vlStyle As XlDVAlertStyle, vlOperator As XlFormatConditionOperator, _
vlFormula1 As Variant, Optional vlFormula2 As Variant) As Boolean
On Error GoTo errh
Rem das ist eine Krücke, denn als eierlegende Wollmilchsau !
Rem muss die Funktion ja erkennen ob Objekt existiert
Rem womöglich verbesserungswürdig
If Len(vCell.Validation.Parent) > 0 Then
Rem Aha, da ist was - lösche es wenn nichts eingegeben wurde
If tLen = 0 Then
Application.EnableEvents = False
vCell.Validation.Delete
vCell.Formula = vbNullString
End If
Rem sonst erzeuge neu
Else
Rem sicherheitshalber, es gibt auch leere Zellen mit Inhalt
If tLen > 0 Then
Rem eigentlich unnötig, da bereits gelöscht sein müsste
vCell.Validation.Delete
Rem auf ein Neues
vCell.Validation.Add Type:=vlType, AlertStyle:=vlStyle, _
Operator:=vlOperator, Formula1:=vlFormula1, Formula2:=vlFormula2
With vCell.Validation
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.Errormessage = ""
.ShowInput = False
.ShowError = True
End With
End If
End If
errh:
Rem wie gesagt, das erzeugte Objekt soll den Fokus erhalten
If Err.number = 0 Then ChkValidation = True
Application.EnableEvents = True
End Function