Gültigkeitsprüfung mit Mehrfachauswahl
Mit dieser Tabellenblatt-Funktion kann man in Excel in Gültigkeitslisten mehrere Werte auswählen und auch wieder entfernen.
Anforderung:
In einer Excelliste sollen nur bestimmte Werte eingeben werden dürfen. Dies ist bereits per Datenüberprüfung mit einer Gültigkeitsliste gelöst. In einzelnen Feldern sollen jetzt aber mehrere Werte ausgewählt werden können.
Lösung:
Es gibt von Excel-Inside Solutions bereits eine Lösung , die den Nachteil hat (oder die Möglichkeit bietet), einen Wert mehrfach einzufügen. Ich habe diese Lösung so erweitert, dass jetzt ein einmal ausgewählter Wert bei erneuter Auswahl wieder aus der Liste entfernt wird.
So sieht die fertige Funktion aus:
Private Sub Worksheet_Change(ByVal Target As Range)
'=====================================================================================
' Eine Tabellenblatt-Funktion aus Raphael Heins Da|ten|bank|Ma|nu|fak|tur
'
' Benutzung: Funktion in jedes Blatt in dem die Funktion benötigt wird kopieren
' und den Bereich anpassen
' Funktion: Mehrfachauswahl über DropDown-Liste (Datenüberprüfung) ermöglichen
' Besonderheit: Bereits ausgewählte werte werden wieder entfernt
'
' Autoren: Alois Eckl, Raphael Hein
' Datum: 14.06.2016
'=====================================================================================
Dim rngDdf As Range ' Range mit Dropdown-Feldern
Dim strOld As String ' Neuer Wert
Dim strNew As String ' Alter Wert
On Error GoTo Errorhandling
' Bereich oder Zellen mit Mehrfachauswahl festlegen (z. B. auch "C6,C8:10")
If Not Application.Intersect(Target, Range("C6")) Is Nothing Then '<=== Anpassen
' Nur Zellen mit Gültigkeitsprüfung bearbeiten
Set rngDdf = Target.SpecialCells(xlCellTypeAllValidation)
If rngDdf Is Nothing Then GoTo Errorhandling
' Prüfen, ob eine gültige Zelle ausgewählt wurde
If Not Application.Intersect(Target, rngDdf) Is Nothing Then
Application.EnableEvents = False
strNew = Target.Value
Application.Undo
strOld = Target.Value
' Ist der neue Wert bereits in der Zelle enthalten
If InStr(strOld, strNew) > 0 Then
' Dann wieder rauslöschen
Select Case True
' Wert steht an erster Stelle oder mittendrin
Case InStr(strOld, strNew & ", ") > 0
strNew = Replace(strOld, strNew & ", ", "")
' Wert steht am Ende
Case InStr(strOld, ", " & strNew) > 0
strNew = Replace(strOld, ", " & strNew, "")
' Wert steht als einziger in der Liste
Case InStr(strOld, strNew) > 0
strNew = Replace(strOld, strNew, "")
End Select
Target.Value = strNew
Else
' sonst hinten anhängen
Target.Value = strNew
If strOld <> "" Then
If strNew <> "" Then
Target.Value = strOld & ", " & strNew
End If
End If
End If
End If
Application.EnableEvents = True
End If
Errorhandling:
Application.EnableEvents = True
End Sub
Diese Funktion arbeitet natürlich auch in Excel:mac. Eine Arbeitmappe mit der Funktion, Beispielen und Erklärungen gibt es für Sie zum Download.