ub MoveToArchiv()
ActiveSheet.Unprotect Password:=""
Dim i As Long
Dim lRows As Long
Dim vntResult As Variant
Dim wksToDo As Worksheet
Dim wksArchiv As Worksheet
Set wksToDo = ActiveWorkbook.Worksheets("ToDo")
Set wksArchiv = ActiveWorkbook.Worksheets("Archiv")
lRows = wksToDo.UsedRange.SpecialCells(xlCellTypeLastCell).Row
For i = lRows To 2 Step -1
Set vntResult = wksToDo.Range(wksToDo.Cells(i, 8), wksToDo.Cells(i, 8)).Find( _
What:="erledigt", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
If Not vntResult Is Nothing Then
wksToDo.Rows(i).Copy
wksArchiv.Rows(2).Insert Shift:=xlDown
wksToDo.Rows(i).Delete Shift:=xlUp
End If
Set vntResult = Nothing
Next i
Application.CutCopyMode = False
Set wksToDo = Nothing
Set wksArchiv = Nothing
ActiveSheet.Protect Password:=""
End Sub