Zeilen mit speziellem Wert verschieben

Sub move()
Dim lastFilterdRow
Dim wksZiel As Worksheet
ActiveSheet.Range("$A:$ZZ").AutoFilter Field:=3, Criteria1:="0000"
lastFilterdRow = GetFilteredRangeBottomRow
ActiveSheet.Range("$A:$ZZ").AutoFilter Field:=3, Criteria1:="0000.03"
With ActiveSheet.AutoFilter.Range
.Offset(1, 0).Resize(.Rows.Count - 2).Copy
End With
ActiveSheet.Paste Destination:=Worksheets(1).Range("A" & lastFilterdRow + 1)
With ActiveWorkbook.Worksheets(1)
.Cells(1, 1).End(xlUp).Offset(lastFilterdRow, 0).PasteSpecial Paste:=xlPasteAll
End With
End Sub
Function GetFilteredRangeBottomRow() As Long
Dim HeaderRow As Long, LastFilterRow As Long, Addresses() As String
On Error GoTo NoFilterOnSheet
With ActiveSheet
HeaderRow = .AutoFilter.Range(1).Row
LastFilterRow = .Range(Split(.AutoFilter.Range.Address, ":")(1)).Row
Addresses = Split(.Range((HeaderRow + 1) & ":" & LastFilterRow). _
SpecialCells(xlCellTypeVisible).Address, "$")
GetFilteredRangeBottomRow = Addresses(UBound(Addresses))
End With
NoFilterOnSheet:
End Function