Sub aimv()
Dim ws As Worksheet
Dim wb As Workbook
Dim r As Range
Dim cc As Long, cr As Long
Dim i, x
Set wb = ActiveWorkbook
Application.ScreenUpdating = False
    cc = Cells(2, Columns.Count).End(xlToLeft).Column
    cr = Cells(Rows.Count, 2).End(xlUp).Row
        For i = 2 To cc
            If Cells(2, i).MergeCells = True Then
                x = Cells(2, i).MergeArea.Columns.Count
                Set r = Range(Cells(2, i), Cells(cr, x + 2 + i))
                Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
                ws.Name = Sheets("Лист1").Cells(2, i).Value
                r.Copy Worksheets(ws.Name).Range("A1")
                Sheets("Лист1").Select
                i = i + x + 2
            End If
        Next i
For i = 2 To Sheets.Count
        x = Sheets(i).Name
        Sheets(i).Copy
        ActiveWorkbook.SaveAs wb.Path & "\" & x & ".xlsx"
        ActiveWorkbook.Close
Next i
Application.ScreenUpdating = True
End Sub