Sub DivideTable1()
Dim FoundCell As Range
Dim FAdr As String
Dim FRow As Long
Dim ERow As Long
Dim NameList As String
Dim List1 As Worksheet
  Set List1 = ThisWorkbook.Worksheets("Исходный формат")
  Set FoundCell = Columns("B:AA").Find("Сведения о клиенте", , xlValues, xlWhole)
   If Not FoundCell Is Nothing Then
     FAdr = FoundCell.Address
     Do
       FRow = FoundCell.Row
       ERow = Cells(FRow + 6, "V").End(xlDown).Row
        NameList = Split(FoundCell.Offset(1), " ")(2)
        Worksheets.Add After:=Worksheets(Worksheets.Count)     'созданный лист будет активным
        ActiveSheet.Name = NameList
        List1.Range(List1.Cells(FRow, "A"), List1.Cells(ERow, "AD")).Copy
          Range("A2").PasteSpecial xlPasteColumnWidths
          Range("A2").PasteSpecial xlPasteAll
          Range("A1").Select
        List1.Select
        Set FoundCell = Columns("B:AA").FindNext(FoundCell)
     Loop While FoundCell.Address <> FAdr
   End If
   Application.CutCopyMode = False
End Sub