AW: (D)eine Beispieldatei wäre hilfreich ...
02.02.2020 14:03:11
volti
Hallo Wolfgang,
evtl. gäbe es auch noch eine reine VBA Lösung, ohne Hilfsspalte usw.
Eine Idee dazu zeigt der nachfolgende, natürlich noch erweiterbare Code.
Wichtig hierbei ist nur, dass die DropDownboxen bei größerem Inhalt vor dem Abspeichern der Datei aufgrund eine M$-Bugs gelöscht werden müssen. Sie werden aber bei Anklick wieder reaktiviert.
Wenn Du magst, kannst Du ihn Dir ja mal anschauen....
Option Explicit
Option COMPARE TEXT
Const csDropDownfelder = "$A$1,$C$1" 'Wo sind die DropDowns
Const csDatenbereich = "Daten!$B1:$B100" 'Woher kommen die Daten
Sub DeleteAllDropDowns()
'Alle DropDown löschen, um Mengenkonflikte zu vermeiden
On Error Resume Next
ThisWorkbook.Sheets("Tabelle1").Cells.Validation.Delete
End Sub
Sub Set_Validation(rOrt As Range)
Dim oRng As Range, sWerte As String, sArr() As String
If InStr(csDropDownfelder, rOrt.Address) = 0 Then Exit Sub
sArr = Split(csDatenbereich, "!")
For Each oRng In Sheets(sArr(0)).Range(sArr(1))
With oRng
If .Value Like rOrt.Value & "*" Or Len(rOrt.Value) > 5 Then
If .Value <> "" Then sWerte = sWerte & .Value & ","
End If
End With
Next oRng
If sWerte <> "" Then sWerte = Left$(sWerte, Len(sWerte) - 1)
With rOrt.Validation
.Delete
If sWerte <> "" Then
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:=sWerte
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = False
End If
Application.EnableEvents = False
rOrt.Select
Application.EnableEvents = True
End With
End Sub
'in Tabelle1
Private Sub Worksheet_Change(ByVal Target As Range)
Set_Validation Target
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set_Validation Target
End Sub
'In diese Arbeitsmappe
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Call DeleteAllDropDowns
End Sub
viele Grüße
Karl-Heinz