DropDown Mehrfachauswahl

[alti89]

Hi Zusammen,

hab ein Excel wo ich Per Drobdown mehrere Werte hintereinander in eine Zelle schreiben kann , das ist der Code:

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("D3:D204")) 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
   Application.Undo
   wertold = Target.Value
   Target.Value = wertnew
   If wertold <> "" Then
     If wertnew <> "" Then
       Target.Value = wertold & "/ " & wertnew
     End If
   End If
 End If

End If

Errorhandling:
Application.EnableEvents = True
End Sub

wie kann ich hier eine " abwahl " generieren, am liebsten wäre mir wenn ich den gleich wert nochmals auswähle das er dann gelöscht wird

[Kuwer]

Hallo,

ungetestet:

 '** 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
  Application.Undo
  wertold = Target.Value
  Target.Value = wertnew
  If wertold <> "" Then
    If wertnew <> "" Then
       If Right(wertold, Len(wertnew)) = wertnew Then
         Target.Value = Left(wertold, Len(wertold) - Len(wertnew) - 2)
       Else
         Target.Value = wertold & "/ " & wertnew
       End If
    End If
  End If
End If

Code eingefügt mit: Excel Code Jeanie

Es wird aber nur auf den letzten Eintrag geprüft.

Gruß Uwe

[alti89]

Hi,

Compile Error:

Block If Without End If.

Gruß

[Kuwer]

Hi,

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("D3:D204")) 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
   Application.Undo
   wert_old = Target.Value
   Target.Value = wertnew
   If wert_old <> "" Then
     If wertnew <> "" Then
       If Right(wert_old, Len(wertnew)) = wertnew Then
         Target.Value = Left(wert_old, Len(wert_old) - Len(wertnew) - 2)
       Else
         Target.Value = wert_old & "/ " & wertnew
       End If
     End If
   End If
 End If

End If

Errorhandling:
Application.EnableEvents = True
End Sub

Code eingefügt mit: Excel Code Jeanie

Gruß Uwe

[alti89]

Danke ::)Funktioniert 1 a :)