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 :)