AW: Abhängige Dropdown Listen mittels VBA
08.09.2019 09:51:59
Matthias
Moin!
HIer mal ein Beispiel. Die Anordnung der Daten ist dafür aber suboptimal. Deshalb musst du im Code den Bereich fest angeben. Wenn du die DAten in einem extra Blatt aufführst und anders Strukturierest, könnte man das auch automatisch, ohne Bereich machen und du könntest ggf. leichter Werte hinzufügen. Bei dir müsstest du sonst ggf. jeden Zielbereich anfügen. Die Listen für die in Spalte E angezeigten WErte, ist in der extra sub und dem Worksheetchange. Dort je nach Wert in Spalte A eine Liste erstellen und die Ergebnisse der Auswahl (Werte in Spalte C) und deren Anzeigebereich (Bereich in Spalte E) ergänzen. Hört sich jetzt kompliziert an, kann man aber am Beispiel erkennen. Damit deine Auswahl in Spalte A auch nur die eingetragenen Werte hat, das hier mal in DieseArbeitsmappe packen (damit wird beim Start die Gültigkeit in A gesetzt und in C und E gelöscht.
Private Sub Workbook_Open()
Dim zeile As Long
Dim werte As Variant
werte = ""
For zeile = 2 To 19
If Tabelle1.Cells(zeile, 1) "" Then werte = werte & Tabelle1.Cells(zeile, 1) & ","
Next
If werte "" Then werte = Left(werte, Len(werte) - 1)
With Tabelle1.Range("A21").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=werte
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Tabelle1.Range("c21").Validation.Delete
Tabelle1.Range("e21").Validation.Delete
End Sub
und das hier in Tabelle 1
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ende
Application.EnableEvents = False
Select Case Target.Address
Case "$A$21"
Range("C21").Value = "please choose..."
'Range("E21").Value = "please choose..."
gültigkeit_einfügen 1, Target.Value, "C21"
Range("e21").Validation.Delete
Case "$C$21"
Range("E21").Value = "please choose..."
bereich = Split(Tabelle1.Range("A21").Validation.Formula1, ";")
auswahl = Application.WorksheetFunction.Match(Tabelle1.Range("A21").Value2, bereich, _
0)
gültigkeit_einfügen auswahl + 1, Target.Value, "E21"
Case "$E$21"
Case Else
End Select
ende:
Application.EnableEvents = True
End Sub
Sub gültigkeit_einfügen(mylist, suche, ziel)
On Error GoTo ende
Dim bereich As Variant
Dim eintrag As Long
bereich = "="
Application.EnableEvents = True
'für jeden Wert in Spalte A eine Liste, dabei immer wert und anzeigebereich
'gibt es keinen Anzeige ereich dann "" eingeben
'die Listen im Array listen auflisten
liste1 = Array("Test1", "C2:C4", "Test2", "C13:C15")
liste2 = Array("a", "e2:e4", "b", "e5:e7", "c", "e8:e10")
liste3 = Array("x", "e13:e15", "y", "", "z", "")
listen = Array(0, liste1, liste2, liste3)
For eintrag = 0 To UBound(listen(mylist)) Step 2
If listen(mylist)(eintrag) = suche Then
bereich = bereich & listen(mylist)(eintrag + 1)
Exit For
End If
Next
If bereich "=" Then
With Tabelle1.Range(ziel).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=bereich
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
ende:
Application.EnableEvents = True
End Sub
VG