Option Explicit

Dim aList As Variant
Dim aRow As Variant

Sub Создать_файлы()
    Init_aList
    
    Dim y As Long
    For y = 2 To UBound(aList, 1)
        RowJob y
    Next
End Sub

Private Sub RowJob(y As Long)
    FillRow y
    
    ThisWorkbook.Sheets("Бланк").Copy
    Dim wb As Workbook
    Set wb = ActiveWorkbook
    
    With wb.Sheets(1).Cells(1, 2).Resize(UBound(aRow, 1), UBound(aRow, 2))
        .Value = aRow
    End With
    
    Dim sName As String
    Dim sFull As String
    sName = aRow(1, 1)
    sName = sName & ".xlsx"
    sFull = ThisWorkbook.Path & "\" & sName
    On Error Resume Next
    Workbooks(sName).Close
    Kill sFull
    On Error GoTo 0
    
    wb.SaveAs Filename:=sFull, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    wb.Close False
End Sub

Private Function FillRow(y As Long)
    Dim x As Integer
    For x = 1 To UBound(aRow, 1)
        aRow(x, 1) = aList(y, x)
    Next
End Function

Private Sub Init_aList()
    With ThisWorkbook.Sheets("Список")
        aList = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp).Cells(1, 5))
    End With
    ReDim aRow(1 To UBound(aList, 2), 1 To 1)
End Sub