Public Sub Übertragen()
Dim loLetzteQ As Long, loLetzteZ As Long
Dim wsQ As Worksheet, wsZ As Worksheet
Dim raRange As Range, raZelle As Range
Application.ScreenUpdating = False
Set wsQ = ThisWorkbook.Worksheets("Aktuell")
Set wsZ = ThisWorkbook.Worksheets("August")
With wsQ
loLetzteQ = .Cells(.Rows.Count, 13).End(xlUp).Row
loLetzteZ = wsZ.Cells(wsZ.Rows.Count, 1).End(xlUp).Row + 1
Set raBereich = .Range(.Cells(2, 13), .Cells(loLetzteQ, 13))
For Each raZelle In raBereich
If raZelle < Date Then
raZelle.EntireRow.Copy wsZ.Cells(loLetzteZ, 1)
raZelle.EntireRow.Delete
loLetzteZ = loLetzteZ + 1
End If
Next raZelle
End With
Set wsQ = Nothing
Set wsZ = Nothing
Set raBereich = Nothing
Application.ScreenUpdating = True
End Sub