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.

Download

Gültigkeitsprüfung mit Mehrfachauswahl für Excel 2007 (und neuer)
(Datei: Mehrfachauswahl.zip, ca. 17 KB)