Sub SplitToSheets()
Dim HPB As HPageBreak
Dim I&, hpbCount&
Dim FirstCell As Range, EndCell As Range, CopyRange As Range
On Error Resume Next
Application.ScreenUpdating = False
With Worksheets("TDSheet")
  hpbCount = .HPageBreaks.Count + 1
  For I = 1 To hpbCount
    Select Case I
      Case 1
        Set FirstCell = .Range("A1")
        Set EndCell = .Range(.HPageBreaks(I).Location.Address).Offset(-1)
      Case 2 To hpbCount - 1
        Set FirstCell = EndCell.Offset(1)
        Set EndCell = .Range(.HPageBreaks(I).Location.Address).Offset(-1)
      Case hpbCount
        Set FirstCell = EndCell.Offset(1)
        Set EndCell = EndCell.Offset(.Cells(.Rows.Count, "A").End(xlUp).Row - EndCell.Row)
    End Select
    Set CopyRange = .Range(FirstCell, EndCell.Resize(, 33))
    CopyRange.Copy
    Worksheets.Add After:=Worksheets(Worksheets.Count)
    With Worksheets(Worksheets.Count)
      .Range("A1").PasteSpecial Paste:=xlPasteAll
      .Range("A1").Select
      .Name = GetSheetName(CopyRange, I)
      With .PageSetup
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
      End With
    End With
    Set CopyRange = Nothing
  Next
  .Activate
  .Range("A1").Select
End With
Application.ScreenUpdating = True
End Sub

Private Function GetSheetName(iRng As Range, N)
Dim rngAct As Range
Dim iTmp
On Error Resume Next
Set rngAct = iRng.Find(what:="АКТ", LookIn:=xlValues, LookAt:=xlPart)
If Not rngAct Is Nothing Then
  iTmp = Split(rngAct.Value, " ")
  GetSheetName = iTmp(0) & "_" & iTmp(2) & "_(" & N & ")"
End If
End Function

Sub DelSheets()
Dim iSh As Worksheet
Application.DisplayAlerts = False
For Each iSh In Worksheets
  If iSh.Name Like "АКТ*" Then iSh.Delete
Next
Application.DisplayAlerts = True
End Sub