Zeilen verschieben - dann löschen

Hallo,
ich suche schon seit längerem im Archiv, kann aber nichts finden. Ich habe folgendes Problem.
Ich gebe über ein Formular Daten in eine Tabelle ein. Wenn ein Datensatz komplett ist, habe ich mir überlegt, wird meinetwegen in Spalte A ein "X" erfasst. Alle Zeilen mit einem X sollen dann in das zweite Tabellenblatt kopiert werden und aus der Tabelle1 soll der Datensatz rausgelöscht werden (ohne das eine leere Zeile übrig bleibt).
Wichtig ist auch: Die Prozedur wird öfters wiederholt. Das heißt es sollte nicht passieren, dass wenn das Makro 2-mal läuft, dass dann die ersten kopierten Zeilen in Tabelle2 üerschrieben werden, sondern die Daten in Tabelle2 fortgesetzt werden.
Noch schöner wäre es, wenn Excel das immer gleich bei der Eingabe überprüfen würde - also sobad ich das "X" irgendwo erfasse, wird die Zeile ausgeschnitten und in Tabelle2 eingefügt.
Wenn ich mich nicht verständlich genug ausgedrückt habe, meldet euch bitte.
Da ich nun schon seit Stunden suche, hoffe ich dass ihr mir helfen könnt.
Ihr würdet mir einen riesigen Gefallen tun.
Alles Gute
Chris

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim z As Long Dim shZiel As Worksheet If Target.Row < 2 Or Cells(Target.Row, 1) = "" Then Exit Sub Cancel = True 'Damit der Curson anschließend nicht in der Zelle blinkt If MsgBox("Daten verschieben?", vbOKCancel + vbQuestion) = vbCancel Then Exit Sub Set shZiel = Sheets("Tabelle2") 'Namen anpassen! z = shZiel.Cells(Rows.Count, 1).End(xlUp).Row + 1 Cells(Target.Row, 1).EntireRow.Cut Destination:=shZiel.Cells(z, 1) End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim z As Range, ber As Range Dim zeile As Long, i As Long Dim shZiel As Worksheet Set shZiel = Sheets("Tabelle2") 'Namen anpassen! Set ber = Intersect(Target, Range("A2:A65536")) 'Diesen Bereich überwachen 'Zeilen mit X kopieren If Not ber Is Nothing Then For Each z In ber zeile = shZiel.Cells(Rows.Count, 1).End(xlUp).Row + 1 z.EntireRow.Copy Destination:=shZiel.Cells(zeile, 1) Next z End If 'Zeilen mit X löschen zeile = Cells(Rows.Count, 1).End(xlUp).Row For i = zeile To 2 Step -1 If UCase(Cells(i, 1)) = "X" Then Rows(i).Delete shift:=xlUp End If Next i End Sub

Hi Chris,
soory dass es so lange gedauert hat.
Ich habe vergessen, die Ereignisprozeduren abzuschalten. Dann hat der Löschbefehl nochmal die Change-Prozedur ausgelöst.


Private Sub Worksheet_Change(ByVal Target As Range)
Dim z As Range, ber As Range
Dim zeile As Long, i As Long
Dim shZiel As Worksheet
Set shZiel = Sheets("Tabelle2") 'Namen anpassen!
Set ber = Intersect(Target, Range("A2:A65536")) 'Diesen Bereich überwachen
'Zeilen mit X kopieren
On Error GoTo errhandler
Application.EnableEvents = False
If Not ber Is Nothing Then
For Each z In ber
zeile = shZiel.Cells(Rows.Count, 1).End(xlUp).Row + 1
z.EntireRow.Copy Destination:=shZiel.Cells(zeile, 1)
Next z
End If
'Zeilen mit X löschen
zeile = Cells(Rows.Count, 1).End(xlUp).Row
For i = zeile To 2 Step -1
If UCase(Cells(i, 1)) = "X" Then
Rows(i).Delete shift:=xlUp
End If
Next i
errhandler:
Application.EnableEvents = True
End Sub

Gruß Matthias

Beliebteste Forumthreads (12 Monate)

Zeilen verschieben - dann löschen

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zeilen verschieben - dann löschen

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread