2 Codes einfügen für ein Modul

[Fred B]

Moin Moin,

ich habe, aufgrund meiner VBA-Unkenntniss, ein kleines Problem.

Und zwar möchte ich, dass bei einer Dropdownauswahl, die ausgewählten Zellen nebeneinander stehen. Dies habe ich bereits mit einem Code von einem Forum hinbekommen.
Jedoch geht dieser Code nur für den Bereich D2:D73. Ich bräuchte diese Funktion allerdings auch für den Bereich B2:B73. Nun weiß ich weder, wie man den Code umschreibt, noch wie man 2 Codes einfügt im selben Modul.

Hier 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("D2:D73")) 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
     Application.EnableEvents = True
  End If
 
Errorhandling:
  Application.EnableEvents = True
End Sub

Vielen Dank für Eure Mühe im voraus

MfG
Fred

[Steffl]

Hallo Fred,

versuche es mal so

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 wertold 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, Union(Range("B2:D73"), Range("D2:D73"))) 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
      Application.EnableEvents = True
   End If
  
Errorhandling:
   Application.EnableEvents = True
End Sub

PS: wert_old <> wertold :17:

[Glausius]

Hallo Stefan,

reicht da nicht:

Code:

If Not Application.Intersect(Target, Range("B2:D73")) Is Nothing Then

[Steffl]

Hallo Günter,

ich denke mal, die Spalte C soll von der Prüfung ausgenommen werden. Vielleicht ginge es tatsächlich etwas kürzer

Code:

If Not Application.Intersect(Target, Range("B2:B73,D2:D73")) Is Nothing Then

[Fred B]

Hallo Günter,

ich denke mal, die Spalte C soll von der Prüfung ausgenommen werden. Vielleicht ginge es tatsächlich etwas kürzer

Code:

If Not Application.Intersect(Target, Range("B2:B73,D2:D73")) Is Nothing Then

Moin Stefan,

vielen Dank, hat super funktioniert :)

[snb]

Wenn eine Zelle ein Validation hat ist diese ganze Code doch überflüssig ?