Sub A_2()
Dim i As Integer
Dim j As Integer
Dim k As Integer

i = Application.WorksheetFunction.CountA(Range("D:D"))
'MsgBox i

For j =  1  To i

tt =  1 
Label1:
 
   For k = tt To  20 
       
       If Cells(k,  4 ).Value = "" Then
          tt = k +  1 
          GoTo Label1
       Else
        'MsgBox Cells(k, 4).Value
        ActiveWorkbook.Sheets.Add Before:=Worksheets(Worksheets.Count)
        Worksheets(j).Name = Worksheets("Исходник").Cells(k,  4 ).Value
       End If
     
   Next k
   
Next j

End Sub