Macro Cortar filas de una hoja

En un modulo pega esto:
Sub crea_hoja()
Dim i As Integer
Dim n As Integer
Dim hoja As String
Application.ScreenUpdating = False
Worksheets.Item(1).Select
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("A:A").Select
    Selection.Copy
    Range("B1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Range("$B$1:$B$65535").RemoveDuplicates Columns:=1, Header:=xlNo
    Range("B1").Select
[b65536].Formula = "=COUNTA(R[-65535]C:R[-1]C)"
[A65536].Formula = "=COUNTA(R[-65535]C:R[-1]C)"
n = [b65536].Value
For i = 1 To n
   Sheets.Add after:=Worksheets(Worksheets.Count)
   Worksheets.Item(Worksheets.Count).Name = Worksheets.Item(1).Range("B" & i)
DoEvents
Next
Worksheets.Item(1).Select
    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
    [a1].Select
n = [A65536].Value
    For i = 1 To n
        Worksheets.Item(1).Select
       Worksheets.Item(1).Range("A" & i).Select
       Selection.EntireRow.Select
       Selection.Cut
       hoja = Worksheets.Item(1).Range("A" & i)
       Sheets(hoja).Select
       Range("A65536").Select
       Selection.End(xlUp).Select
       Selection.Offset(1, 0).Select
       ActiveSheet.Paste
    DoEvents
    Next
Worksheets.Item(1).Select
    [A65536].Clear
    [a1].Select
Application.ScreenUpdating = True
MsgBox "Terminado", vbInformation
End Sub
se entiende que los datos estan en la hoja 1 desde A1 ( sin rotulos)
ejecutala con ALT + F8