Mehrfachauswahl bei Datenüberprüfung, keine doppelte Auswahl

Code:
Private Sub Worksheet_Change(ByVal Target As Range)

'** Mehrfachauswahl über DropDown-Liste (Gültigkeitsprüfung)

'** Einfügen im Code-Container des betreffenden Arbeitsblattes

 

'** Dimensionierung der Variablen

Dim rngDV As Range

Dim wert_old As String

Dim wertnew As String

 

'** Errorhandling

On Error GoTo Errorhandling

 

'** Mehrfachauswahl im definierten Bereich (Bsp. B4:B14) durchführen

If Not Application.Intersect(Target, Range("G12:G9999, H12:H9999, I12:I999")) Is Nothing Then

 

  '**Range definieren

  Set rngDV = Target.SpecialCells(xlCellTypeAllValidation)

  If rngDV Is Nothing Then GoTo Errorhandling

   

  '** Prüfen, ob eine gültige Zelle ausgewählt wurde und Werte eintragen

  If Not Application.Intersect(Target, rngDV) Is Nothing Then

    Application.EnableEvents = False

    wertnew = Target.Value '** trägt das ausgewählte in die Variable "wertnew" ein

    Application.Undo '** macht es sofort rückgängig

    wertold = Target.Value '** es wird geguckt was vorher drin stand und wird in die Variable "wertold" eingetragen

    Target.Value = wertnew

    If wertold <> "" Then

      If wertnew <> "" Then

        Target.Value = wertold & ", " & wertnew

      End If

    End If

  End If

  Application.EnableEvents = True

End If

 

Errorhandling:

Application.EnableEvents = True

End Sub