Office: Bestimmte Zeilen übertragen und löschen

Hallo,

jetzt habe ich auch mal wieder ein Problem:

Ich möchte alle Zeilen, die in Spalte A mit "C" gekennzeichnet sind, in ein anderes Tabellenblatt übertragen.

Folgendes Makro verwende ich hierfür:

Code:

Sub SätzeAufAnderesTabellenblattÜbertragen1()
Dim i As Integer
Dim iAnz As Integer
Dim x As Integer
 Application.ScreenUpdating = False
 Sheets(1).Activate
 Range("A2").Select
 iAnz = 0
 i = 0

 Do Until i = ActiveSheet.UsedRange.Rows.Count
  If ActiveCell.Value = "C" Then
     Selection.EntireRow.Copy
     Sheets(2).Select
     x = Sheets(2).Range("a65536").End(xlUp).Row
     Sheets(2).Cells(x + 1, 1).Select
     ActiveSheet.Paste
     ActiveCell.Offset(1, 0).Select
     Sheets(1).Select
     Selection.EntireRow.Delete
     iAnz = iAnz + 1
     Else
     ActiveCell.Offset(1, 0).Select
   End If
   i = i + 1
 Loop
 Application.CutCopyMode = False
 Application.ScreenUpdating = True
 MsgBox "Es wurden " & iAnz & " Sätze übertragen"
End Sub

Manchmal überträgt er wie erwünscht alle Zeilen, manchmal aber nur einige und ab und zu gibt er mir einen Laufzeitfehler.

Wo ist der Fehler?
Zum besseren Verständnis habe ich die Datei mal angehängt.

Gruß, Werner

 

Hallo!

Durch das Löschen der Zeilen verschiebt sich immer wieder der Zeilenindex.
Arbeite in solchen Fällen am besten immer von UNTEN nach OBEN.
Die Anweisung "Select" ist in 99% aller Fälle überflüssig!

Code:

Sub SätzeAufAnderesTabellenblattÜbertragen1()
Dim i As Integer
Dim iAnz As Integer
Dim x As Integer
 Application.ScreenUpdating = False
 iAnz = 0
 With Sheets(1)
 i = .UsedRange.Rows.Count   '<--- fängt unten an
 Do Until i = 1
  If .Cells(i, 1).Value = "C" Then
     .Rows(i).Copy Sheets(2).Cells(Sheets(2).Range("A65536").End(xlUp).Row + 1, 1)
     .Rows(i).Delete
     iAnz = iAnz + 1
  End If
  i = i - 1   '<--- arbeitet nach oben
 Loop
 Application.CutCopyMode = False
 Application.ScreenUpdating = True
 MsgBox "Es wurden " & iAnz & " Sätze übertragen"
 End With
End Sub

 

Hallo Schatzi,

perfekt, es funktioniert :-D .
Toll wie schnell einem hier geholfen wird und ganz nebenbei lernt man noch eine Menge dazu !!!

Vielen Dank und frohe Ostern.

Gruß, Werner