Sub Framed()
Dim arr()
Dim iArr()
Dim dic As Object
Dim xlWb As Workbook
Dim I&, J&, n&, iKey
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Worksheets("Вырузка")
    arr = .Range("A2:H" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
End With
On Error Resume Next
Set dic = CreateObject("Scripting.Dictionary")
With dic
    For I = 1 To UBound(arr)
        ReDim iArr(7, 0)
        .Add arr(I, 1), Empty
        If Err <> 0 Then
            iArr = .Item(arr(I, 1))
            n = UBound(iArr, 2) + 1
            ReDim Preserve iArr(7, n)
            Err.Clear
        Else
            n = 0
        End If
        For J = 0 To 7
            iArr(J, n) = arr(I, J + 1)
        Next
        .Item(arr(I, 1)) = iArr
    Next
    For Each iKey In .Keys
        Set xlWb = Workbooks.Add(1)
        With xlWb
            With .Worksheets(1)
                .Name = iKey
                .Range("A1").Resize(UBound(dic.Item(iKey), 2) + 1, 8) = Application.Transpose(dic.Item(iKey))
                .Cells.EntireColumn.AutoFit
            End With
            .SaveAs ThisWorkbook.Path & Application.PathSeparator & iKey & ".xlsx"
            .Close False
        End With
    Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Sub Framed()
Dim arr()
Dim iArr()
Dim dic As Object
Dim xlWb As Workbook
Dim I&, J&, n&, iKey
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Worksheets("Вырузка")
    arr = .Range("A1:H" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
End With
On Error Resume Next
Set dic = CreateObject("Scripting.Dictionary")
With dic
    For I = 2 To UBound(arr)
        ReDim iArr(7, 0)
        .Add arr(I, 1), Empty
        If Err <> 0 Then
            iArr = .Item(arr(I, 1))
            n = UBound(iArr, 2) + 1
            ReDim Preserve iArr(7, n)
            Err.Clear
        Else
            n = 0
        End If
        For J = 0 To 7
            iArr(J, n) = arr(I, J + 1)
        Next
        .Item(arr(I, 1)) = iArr
    Next
    For Each iKey In .Keys
        Set xlWb = Workbooks.Add(1)
        With xlWb
            With .Worksheets(1)
                .Name = iKey
                .Range("A1").Resize(1, 8) = Application.Index(arr, 1, 0)
                .Range("A2").Resize(UBound(dic.Item(iKey), 2) + 1, 8) = Application.Transpose(dic.Item(iKey))
                .Cells.EntireColumn.AutoFit
            End With
            .SaveAs ThisWorkbook.Path & Application.PathSeparator & iKey & ".xlsx"
            .Close False
        End With
    Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub