Sub ertert()
Dim r As Range, i&, hdr As Range, s$, lr&: Application.ScreenUpdating = False
With Sheets("дела")
     lr = .Cells(Rows.Count, 2).End(xlUp).Row
     Set r = .Range("B1"): Set hdr = .Range("A9:F10")
     For i = 11 To lr
         Do While .Cells(i, 1).MergeCells = False And i < lr
             Set r = Union(r, .Cells(i, 1)): i = i + 1
         Loop
         If r.Count > 1 Then
             With Intersect(.Columns(1), r).Resize(, 6)
                 With .Offset(-1).Resize(.Rows.Count + 1)
                     Sheets.Add after:=Sheets(Sheets.Count)
                     hdr.Copy
                     Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
                     Range("A1").PasteSpecial Paste:=xlPasteAll
                     .Copy Range("A3")
                 End With
             End With
             Set r = .Range("B1")
         End If
     Next i
End With
With Application
     .ScreenUpdating = True: .CutCopyMode = False
End With
End Sub