Office: (Office 2013) Bestimmte Zeilen Ausschneiden und in anderes Tabellenblatt einfügen

Hallo, ich habe folgendes Problem:

Mein Makro soll alle (kompletten) Zeilen von Tabelle 1 in Tabelle 2 verschieben, bei denen in der Spalte 1 der Wert größer als 4999 ist.
Habe mir ein Makro zusammengebastelt, leider übernimmt es nicht alle Reihen.
Außerdem möchte ich den Bereich definieren, in dem die ausgeschnittenen Reihen eingefügt werden. (also nicht bei A1 anfangen, sondern bei C3 und ab da dann abwärts)

PHP:

Option Explicit

Public Sub ZeilenFilternUndVerschieben()
Dim loLetzte As Long
Dim loLetzteTab3 As Long
Dim loAnzahl As Long
Dim loCounter As Long

loAnzahl = 0

    With ThisWorkbook.Worksheets("Tabelle1")
       loLetzteTab3 = .UsedRange.Rows.Count + 1
    End With
    
    With Me
       loLetzte = .UsedRange.Rows.Count + 1
        For loCounter = 1 To loLetzte
            If .Cells(loCounter, 1).Value > 4999 Then
                loAnzahl = loAnzahl + 1
            End If
        Next loCounter
        For loCounter = loLetzte To 1 Step -1
            If .Cells(loCounter, 1).Value > 4999 Then
                .Rows(loCounter).EntireRow.Cut Destination:=ThisWorkbook.Worksheets("Tabelle2").Rows(loLetzteTab3)
                .Rows(loCounter).EntireRow.Delete shift:=xlUp
                loAnzahl = loAnzahl - 1
            End If
        Next loCounter
    End With
    
End Sub


Ich hoffe jemand kann mir helfen

 

Hallo,

versuche es mal so. Hier werden die Daten erst in ein Array gezogen und mit einer For-Schleife durchlaufen. Trifft die Bedingung zu, werden die entsprechenden Daten in ein neues Array geschrieben. Dieses Array wird dann am Stück ab Zelle C3 eingefügt.

Ungetestet:

Code:

Option Explicit

Public Sub ZeilenFilternUndVerschieben()
    Dim loLetzteTab3 As Long
    Dim loCounter As Long
    Dim arrTab3
    Dim arrNeu()
    Dim i As Long
    
    With ThisWorkbook.Worksheets("Tabelle1")
        loLetzteTab3 = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        arrTab3 = .Range("A1:A" & loLetzteTab3)
    End With
    
    With Me
        For loCounter = LBound(arrTab3) To UBound(arrTab3)
            If arrTab3(loCounter, 1) > 4999 Then
                ReDim Preserve arrNeu(i)
                arrNeu(i) = arrTab3(loCounter)
                i = i + 1
            End If
        Next loCounter
        
        .Range("C3:C" & UBound(arrNeu) + 1) = arrNeu
    End With
End Sub