Clever-Excel-Forum

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

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.

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

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

mxlrnz

schauan

steve1da

Gast 123