Nach jedem zweiten Satz Fehlermeldung

Sub SätzeAufAnderesTabellenblattÜbertragen()
Dim Orginal As String
Dim Kopie As String
Dim Z As Integer
Dim ZAnz As Integer
Dim Var As Integer
Orginal = ActiveSheet.Name
Kopie = Orginal & "Copy"
Application.ScreenUpdating = False
Sheets(Orginal).Activate
Range("A4").Select
ZAnz = 0
Z = 0
Var = 1
Do Until Z = ActiveSheet.UsedRange.Rows.Count
If ActiveCell.Value = "x" Then
Selection.EntireRow.Copy
Sheets(Kopie).Activate
ActiveSheet.Unprotect
Do Until Cells(Var, 1).Value = ""
Var = Var + 1
Loop
Rows(Var).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
ActiveSheet.Protect
Sheets(Orginal).Select
Selection.EntireRow.Delete
ZAnz = ZAnz + 1
Else
ActiveCell.Offset(1, 0).Select
End If
Z = Z + 1
Loop
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Es wurden " & ZAnz & " Sätze übertragen"
End Sub