Thomas Risi Softwareentwicklung

Mehrfachauswahl aus Gültigkeitsliste (2)
Downloads Demo-Datei

Aus einer Frage in einem Forum ...

In Spalte C einer Tabelle, gibt es mehrere Zellen die eine Liste als Gültigkeitskriterium enthalten. Es soll nun möglich sein, mehrere dieser Werte in der jeweiligen Zelle, durch ein Komma getrennt, darzustellen.

Hier ist es auch möglich, eingefügte Werte durch nochmaliges Anklicken wieder zu löschen. Und sogar Sortieren kann man ...


Quellcode für z.B. Tabelle1 ...

Option Explicit Const TargetColumn As Long = 3 ' Ziele in Spalte 3. Const bolSorted As Boolean = True ' Legt fest, ob die Werte noch sortiert werden. Dim blockedEvent As Boolean Dim TargetOldText As String Private Sub Worksheet_Change(ByVal Target As Range) Dim strResult As String Dim strTarget As String Dim arrSorted As Variant Dim i As Long If Target.Column = TargetColumn Then strTarget = Trim$(Target.Value) If Not blockedEvent Then blockedEvent = True If Not TargetOldText = "" And Not Target.Value = "" Then If InStr(1, TargetOldText, Target.Value) > 0 Then strResult = Replace(TargetOldText, ", " & strTarget, "") strResult = Replace(strResult, strTarget & ", ", "") strResult = Replace(strResult, strTarget, "") Else strResult = TargetOldText & ", " & Target.Value End If If bolSorted Then arrSorted = Split(strResult, ", ") strResult = "" Call Selectionsort(arrSorted) For i = 0 To UBound(arrSorted) strResult = strResult & arrSorted(i) & ", " Next i If Len(strResult) > 1 Then _ strResult = Left$(strResult, Len(strResult) - 2) End If Target.Value = strResult Else Target.Value = Target.Value End If TargetOldText = Target.Value Else blockedEvent = False End If Else TargetOldText = "" End If End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error Resume Next If Target.Column = TargetColumn Then TargetOldText = Target.Value End If End Sub Private Sub Selectionsort(ByRef data As Variant) Dim OG&, i&, j&, k&, h As Variant OG = UBound(data) For i = 0 To OG - 1 h = data(i) k = i For j = i + 1 To OG If data(j) < h Then h = data(j) k = j End If Next j data(k) = data(i) data(i) = h Next i End Sub

Bewerten Sie bitte dieses Programm.
1 2 3 4 5
Weniger nützlich Sehr nützlich
Bitte teilen Sie uns mit, warum Sie das Programm so bewertet haben. (optional)