Sub Макрос1()
Dim i As Integer, j As Integer, r As Integer, m As Integer, k As Integer, n As Integer, f As Integer, g As Integer

Dim Per() As Variant


ThisWorkbook.Sheets("Лист2").Activate
 Set wb = ActiveWorkbook
    r =  0 
    Range("A1").Select
        Do Until IsEmpty(ActiveCell.Value)
            ActiveCell.Offset( 1 ,  0 ).Select
            r = r +  1 
        Loop
    Range("A1").Select
    i =  1 
    For i =  1  To r
            ReDim Preserve Per( 1  To r)
            Per(i) = Cells(i,  1 ).Value
    Next i
Application.DisplayAlerts = True
 For i =  1  To r
        ActiveWorkbook.Worksheets.Add
        ActiveSheet.Name = Per(i)
 Next i
End Sub