Make a new worksheet at every page break in a worksheet

[teachman]

Hello,

I am a gov't employee and as such any documentation or spreadsheet tool I develop has to be something called '508 compliant'. Spreadsheets aren't so bad but when I create a report with page breaks in a spreadsheet that I save as a PDF file, 508 requires every page break to be the end of a chapter in the PDF. Meaning, if I have an Excel report that documents several different aspects of the spreadsheet use as a tool currently I just insert a page break so when users print out the worksheet they get separate pages with headers and footers that I suppose could be considered chapters. I have one project that has about 600 separate sections, describing database tables and columns and choice lists, etc. Each section is separated by a page break. I'm being told that each of the 600 or so separate sections must be a separate worksheet so the PDF tool used to make Excel documents into PDFs can make a chapter out of each section. Each worksheet is considered a chapter.

I'm looking for help so that I can include in my vba scripts that create the main document I can add some code that will create a worksheet and move/copy the section from the main worksheet to the newly created worksheet.

Thanks in advance for any guidance or suggestions.

George Teachman

 

[John_w]

Try this. The code operates on the active sheet in the active workbook, allowing you to run it on any open workbook, and copies rows to new worksheets. The new worksheets are named "Page 1", "Page 2", etc., although it doesn't check whether the named sheets already exist, so the code will crash if this is the case.

Public Sub Copy_Each_Page_Break_Section_To_New_Worksheet()

    Dim reportWorksheet As Worksheet
    Dim saveActiveCell As Range
    Dim lastRow As Long, pageStartRow As Long
    Dim page As Long
    Dim newWorksheet As Worksheet
    
    'Look on the active sheet in the active workbook
    
    Set reportWorksheet = ActiveWorkbook.ActiveSheet
    Set saveActiveCell = ActiveCell
    
    With reportWorksheet
        
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        pageStartRow = 1
        
        'Copy rows in each page break section to new worksheet
        
        For page = 1 To .HPageBreaks.Count            
            Set newWorksheet = .Parent.Worksheets.Add(after:=.Parent.Worksheets(.Parent.Worksheets.Count))
            newWorksheet.Name = "Page " & page
            .Rows(pageStartRow & ":" & .HPageBreaks(page).Location.Row - 1).EntireRow.Copy newWorksheet.Range("A1")            
            pageStartRow = .HPageBreaks(page).Location.Row
        Next
    
        If pageStartRow <= lastRow Then
        
            'Copy rows after last page break to new worksheet
            
            Set newWorksheet = .Parent.Worksheets.Add(after:=.Parent.Worksheets(.Parent.Worksheets.Count))
            newWorksheet.Name = "Page " & page
            .Rows(pageStartRow & ":" & lastRow).EntireRow.Copy newWorksheet.Range("A1")
        
        End If
    
    End With
    
    'Restore active cell
    
    reportWorksheet.Activate
    saveActiveCell.Select
    
End Sub

 

[Arcomvi]

Try this. The code operates on the active sheet in the active workbook, allowing you to run it on any open workbook, and copies rows to new worksheets. The new worksheets are named "Page 1", "Page 2", etc., although it doesn't check whether the named sheets already exist, so the code will crash if this is the case.

Public Sub Copy_Each_Page_Break_Section_To_New_Worksheet()

    Dim reportWorksheet As Worksheet
    Dim saveActiveCell As Range
    Dim lastRow As Long, pageStartRow As Long
    Dim page As Long
    Dim newWorksheet As Worksheet
   
    'Look on the active sheet in the active workbook
   
    Set reportWorksheet = ActiveWorkbook.ActiveSheet
    Set saveActiveCell = ActiveCell
   
    With reportWorksheet
       
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        pageStartRow = 1
       
        'Copy rows in each page break section to new worksheet
       
        For page = 1 To .HPageBreaks.Count           
            Set newWorksheet = .Parent.Worksheets.Add(after:=.Parent.Worksheets(.Parent.Worksheets.Count))
            newWorksheet.Name = "Page " & page
            .Rows(pageStartRow & ":" & .HPageBreaks(page).Location.Row - 1).EntireRow.Copy newWorksheet.Range("A1")           
            pageStartRow = .HPageBreaks(page).Location.Row
        Next
   
        If pageStartRow <= lastRow Then
       
            'Copy rows after last page break to new worksheet
           
            Set newWorksheet = .Parent.Worksheets.Add(after:=.Parent.Worksheets(.Parent.Worksheets.Count))
            newWorksheet.Name = "Page " & page
            .Rows(pageStartRow & ":" & lastRow).EntireRow.Copy newWorksheet.Range("A1")
       
        End If
   
    End With
   
    'Restore active cell
   
    reportWorksheet.Activate
    saveActiveCell.Select
   
End Sub

Hi
Thank you for the code, it works great however, Im hoping you can help with an additional problem to this. I need each tab to be labeled based on a value within a cell on each new speadsheet. There is a catch, the cell that has the data is always on a different row but only ever in one column ie; H
I look forward to your help

 

[John_w]

@Arcomvi, this thread is 7 years old so it's best if you start a new thread.