Sub SplitTable()
Dim ws As Worksheet
Dim lastRow As Long
Dim startRow As Long
Dim endRow As Long
Dim blockCounter As Integer
Dim zak As String

Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("TDSheet")

lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row

blockCounter = 1

For startRow = 1 To lastRow
If InStr(1, ws.Cells(startRow, "B").Value, "Заказ поставщику") > 0 Then
    For endRow = startRow To lastRow
        If InStr(1, ws.Cells(endRow, "B").Value, "Ответственный") > 0 Then
        zak = ws.Cells(startRow, "B").Value
            ws.Rows(startRow & ":" & endRow).Copy
            Dim newWorkbook As Workbook
            Set newWorkbook = Workbooks.Add
            newWorkbook.Sheets(1).Paste
            
            With newWorkbook.Sheets(1).Cells(1)
                .PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
                , SkipBlanks:=False, Transpose:=False
                .PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
                .Select
            End With
    
            newWorkbook.SaveAs ThisWorkbook.Path & "/" & zak & ".xlsx" ' "Заказ_" & blockCounter & ".xlsx"
            newWorkbook.Close SaveChanges:=False
            blockCounter = blockCounter + 1
    Exit For
End If
Next endRow
End If
Next startRow
Application.ScreenUpdating = True
MsgBox "Все заказы обработаны!"
End Sub