Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim trgZeile As Long
Dim lngLaufZahl As Long
Dim Zelle As Excel.Range
If Target.Column <> 5 Then Exit Sub
If Target.Row = 1 Then Exit Sub
On Error GoTo Fehler
Application.EnableEvents = False
Application.ScreenUpdating = False
For Each Zelle In Target
If Zelle.Offset(0, -4) = "" Then Exit Sub
With ThisWorkbook
With .Sheets(2)
.Activate
If Zelle = 1 Then
trgZeile = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row + 1
Zelle.EntireRow.Columns("A:D").Copy
.Cells(trgZeile, 1).Select
Selection.PasteSpecial xlValues
.Cells(trgZeile, 1).Select
ElseIf Zelle = 0 Then
trgZeile = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
For lngLaufZahl = 2 To trgZeile
If .Cells(lngLaufZahl, 1) = Zelle.Offset(0, -4) Then
.Cells(lngLaufZahl, 1).EntireRow.Delete
Exit For
End If
Next lngLaufZahl
Else
Application.EnableEvents = True: DoEvents
Zelle = 0
Exit Sub
End If
End With
.Sheets(1).Activate
End With
Next
Application.SendKeys "{ESC}"
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub
Fehler:
Err.Clear
MsgBox "Ein Fehler ist aufgetreten!" & Chr(10) _
& "Das Programm wird abgebrochen!", vbCritical, "Fehler..."
End Sub