Split the worksheet

Hello,

I need to split the Active worksheet to a new workbook but split the sheet to multiple sheets as following:

1- Create a new workbook.
2- Copy the active sheet.
3- Paste the active sheet to the new workbook after splitting each page to a different sheets using page breaks to split. (paste all formula as text)
4- Keep the print title for each sheet (Row 3 to 9).
5- Save the new workbook at the desktop name is "New AAA".

thanks for usual support,

What is in the first 2 Rows?
Line 3 does not make sense to me. After splitting the sheet, you will have multiple sheets but you ask for the active sheet to copy/paste.
If you split the sheet by pages, the values of the print titles (rows 3 to 9) are going to be different for each sheet. Is that what is needed?

There are instructions at the top of the page explaining how to attach your sample workbook (yellow banner: HOW TO ATTACH YOUR SAMPLE WORKBOOK). Screenshots are of little practical use as we cannot manipulate them.

A good sample workbook has just 10-20 rows of representative data that has been desensitised. The sample layout accurately matches that of your real data. It also has expected results mocked up, worked examples where required, relevant cells highlighted and a few explanatory notes.

Re: "using page breaks to split"
How were these set? Manually or automatically?

I am using the following code for the page breaks
to keep the break always above "P.TAG" in column A and not cutting in the middle.

Sub PAGEBREAK()



 Dim Search As String
 Search = "P.TAG"
 Dim x As Long
 Dim R As Range
 Dim LastRow As Long
 
 ActiveSheet.ResetAllPageBreaks

With ActiveSheet
     Do While x < .HPageBreaks.Count
           For Each R In Range("A" & (LastRow + 1) & ":A" & .HPageBreaks(x + 1).Location.Row)
              If R = Search Then
                  LastRow = R.Row
              End If
           Next R
           If LastRow = 0 Then Exit Sub
           .HPageBreaks.Add before:=Range("A" & LastRow)

           x = x + 1
      Loop
 End With

End Sub

Any reason that the Row Heights below Row 9 are either 15, 12 or 12.75?
If they are different for no particular reason, it is difficult, for me at least, to calculate amount of rows per page.

Your page break settings needs to be changed because of the rows to be repeated at the top.

The Page Breaks are redone. If that's not what you want, take that part out of the code.
Copy all three into a regular Module and run the "Save_As_New_Book" macro.
I don't really know if this is what you want but try it.

Sub Save_As_New_Book()
Dim sh1 As Worksheet, tr As Long, br As Range, lr As Long
Set sh1 = Worksheets("Sheet1")
lr = sh1.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
tr = 10

Do
    
    ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = "From_Row_" & tr
        
    sh1.Range("A1:CP9").Copy ThisWorkbook.Sheets(Sheets.Count).Range("A1")
        Set br = sh1.Range(sh1.Cells(10, 1), sh1.Cells(tr + 80, 1)).Find("P.TAG", , , , , xlPrevious)
    sh1.Range(sh1.Cells(tr, 1), sh1.Cells(br.Row - 1, "CP")).Copy Sheets(Sheets.Count).Cells(10, 1)
    Sheets(Sheets.Count).UsedRange.Value = Sheets(Sheets.Count).UsedRange.Value
        
    tr = br.Row
        
    Set_P_Range
        
    If br.Row + 80 >= lr Then
        ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = "From_Row_" & tr
            sh1.Range("A1:CP9").Copy ThisWorkbook.Sheets(Sheets.Count).Range("A1")
                sh1.Range(sh1.Cells(tr, 1), sh1.Cells(lr, "CP")).Copy Sheets(Sheets.Count).Cells(10, 1)
            Sheets(Sheets.Count).UsedRange.Value = Sheets(Sheets.Count).UsedRange.Value
        Set_P_Range
        GoTo Finish_It_Off
        Exit Sub
    End If
        
Loop
Finish_It_Off: Save_To_Desktop
End Sub

Sub Set_P_Range()
Dim lr As Long, ws As Worksheet
Set ws = ActiveSheet
lr = ws.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
    With ws.PageSetup
        .PrintArea = Range("A1:CP" & lr).Address
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .Orientation = xlLandscape
    End With
End Sub

Sub Save_To_Desktop()
Dim sh As Worksheet, shArr

    For Each sh In ThisWorkbook.Worksheets
        If Left(sh.Name, 9) = "From_Row_" Then shArr = shArr & "|" & sh.Name
    Next sh
    
    shArr = Split(Mid(shArr, 2), "|")
    Sheets(shArr).Copy
    
    With ActiveWorkbook
        .SaveAs Filename:=CreateObject("WScript.Shell").Specialfolders("Desktop") & "\New_AAA.xlsx"
        .Close
    End With
    
End Sub

Change this

sh1.Range("A1:CP9").Copy ThisWorkbook.Sheets(Sheets.Count).Range("A1")

to this

sh1.Range("A1:CP9").Copy
With ThisWorkbook.Sheets(Sheets.Count).Range("A1")
.Paste    'or .PasteSpecial xlPasteValues
.Resize(, 94).PasteSpecial Paste:=xlPasteColumnWidths
End With

Change this

Set sh1 = Worksheets("Sheet1")

to so

Set sh1 = ActiveSheet

In the code there are 2 instances of

sh1.Range("A1:CP9").Copy ThisWorkbook.Sheets(Sheets.Count).Range("A1")

Did you change them both?
See Post #12 on what to change that line to.

Change the "Save_To_Desktop" macro to

Sub Save_To_Desktop()
Dim sh As Worksheet, shArr, i As Long
Application.ScreenUpdating = False
    For Each sh In ThisWorkbook.Worksheets
        If Left(sh.Name, 9) = "From_Row_" Then shArr = shArr & "|" & sh.Name
    Next sh
    
    shArr = Split(Mid(shArr, 2), "|")
    Sheets(shArr).Copy
    
    With ActiveWorkbook
        .SaveAs Filename:=CreateObject("WScript.Shell").Specialfolders("Desktop") & "\New_AAA.xlsx"
        .Close
    End With
    For i = LBound(shArr) To UBound(shArr)
        Application.DisplayAlerts = False
            Sheets(shArr(i)).Delete
        Application.DisplayAlerts = True
    Next i
Application.ScreenUpdating = True
End Sub