Option Explicit

Sub SplitSheetAndSave()
    Dim ws          As Worksheet
    Set ws = ThisWorkbook.Worksheets("Лист1")

    Dim lastRow     As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    Dim i           As Long
    Application.ScreenUpdating = False

    For i = 1 To lastRow

        If ws.Cells(i, 1).value = "Специальный бланк" Then

            Dim startRow As Long
            startRow = i

            Dim endRow As Long
            endRow = startRow

            Do While endRow <= lastRow And ws.Cells(endRow + 1, 1).value <> "Специальный бланк"
                endRow = endRow + 1
            Loop

            Dim fileName As String
            fileName = InputBox("Enter the file name for the block starting at row " & startRow & ":", "File Name Input")
            If fileName = "" Then fileName = "File_" & i

            Dim filePath As String
            filePath = ThisWorkbook.Path & "\" & fileName & ".xlsx"

            Dim wbNew As Workbook
            Set wbNew = Workbooks.Add

            With wbNew.Sheets(1)
                ws.Range(ws.Cells(startRow, 1), ws.Cells(endRow, 9)).Copy
                .Range("A1").PasteSpecial Paste:=xlPasteValues
                Application.CutCopyMode = False
                .Columns("A:I").AutoFit
            End With

            wbNew.SaveAs fileName:=filePath, FileFormat:=xlOpenXMLWorkbook
            wbNew.Close SaveChanges:=False
        End If

    Next i

    Set wbNew = Nothing
    Set ws = Nothing
    Application.ScreenUpdating = True
    MsgBox "Василий, Рабочий лист был разделён на отдельные файлы и сохранены! "
End Sub