2 VBA Codes zusammenfassen

[mxlrnz]

Hi, kann ich diese beiden Codes zusammenfassen in einen?

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("B4:B14")) 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

und

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim lngErste As Long
If Target.Column = 2 Then
If Target.Count = 1 Then
If Target = "Bestand" Then
With Worksheets("Bestand")
lngErste = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
.Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count) + 1
Rows(Target.Row).Copy
.Cells(lngErste, 1).PasteSpecial Paste:=xlValues
Rows(Target.Row).Delete shift:=xlUp
End With


ElseIf Target = "Verkauft" Then
With Worksheets("Verkauft")
lngErste = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
.Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count) + 1
Rows(Target.Row).Copy
.Cells(lngErste, 1).PasteSpecial Paste:=xlValues
Rows(Target.Row).Delete shift:=xlUp
End With


ElseIf Target = "Abgerechnet" Then
With Worksheets("Abgerechnet")
lngErste = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
.Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count) + 1
Rows(Target.Row).Copy
.Cells(lngErste, 1).PasteSpecial Paste:=xlValues
Rows(Target.Row).Delete shift:=xlUp
End With


End If
End If
End If



End Sub

[schauan]

Hallöchen,

schon mal probiert, den einen ans Ende von dem anderen zu kopieren?

Könnte funktionieren, nur ist die Frage, wann was passieren soll. Wenn Du z.B. willst, dass bei Durchlauf des einen der andere nicht ausgeführt wird, müsstest Du zum einen die Reihenfolge beachten und z.B. bei dem anderen irgendwo über ein End If ein Exit Sub setzen.

[steve1da]

Zur Info…
https://www.herber.de/forum/archiv/1960t...ergen.html

[Gast 123]

Hallo

probiere es bitte einmal so, ich habe nur die lngErste verkürzt, ohne IFFs Anweisung.  M.E. unnötig.
Das Sheet hat über 1 Million Zeilen, ich glaube nicht das ihr das Blattende jemals erreichen werdet. Richtig??
Im 1. Code ist der von Schauan erwähnet Exit Sub Befehl eingebaut, er beendet den 1. Code!

Wenn das falsch ist, und der zweite Code auch ausgeführt werden soll, musst du Exit Sub einfach löschen!

mfg Gast 123

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
Dim lngErste As Long

'** Errorhandling
On Error GoTo Errorhandling

'** Mehrfachauswahl im definierten Bereich (Bsp. B4:B14) durchführen
If Not Application.Intersect(Target, Range("B4:B14")) 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
  Exit Sub  '** Beendet den 1. Codeteil
End If

If Target.Column = 2 Then
If Target.Count = 1 Then
If Target = "Bestand" Then
With Worksheets("Bestand")
     lngErste = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
     Rows(Target.Row).Copy
     .Cells(lngErste, 1).PasteSpecial Paste:=xlValues
     Rows(Target.Row).Delete shift:=xlUp
End With

ElseIf Target = "Verkauft" Then
With Worksheets("Verkauft")
     lngErste = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
     Rows(Target.Row).Copy
     .Cells(lngErste, 1).PasteSpecial Paste:=xlValues
     Rows(Target.Row).Delete shift:=xlUp
End With


ElseIf Target = "Abgerechnet" Then
With Worksheets("Abgerechnet")
     lngErste = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
     Rows(Target.Row).Copy
     .Cells(lngErste, 1).PasteSpecial Paste:=xlValues
     Rows(Target.Row).Delete shift:=xlUp
End With

End If
End If
End If

Errorhandling:
Application.EnableEvents = True
End Sub