Creating Workbooks with Page Breaks

[UT_CL]

I have a spreadsheet with data that are separated by page breaks. I'm trying to figure out a VBA script that:

• create workbooks after each page breaks
• save in the same folder as the current spreadsheet with the naming convention (ex. Workbook 1, Workbook 2, etc.)
• each workbook needs the same first two rows

Thanks in advance for any advice.

 

[John_w]

Try this macro, which copies the rows using Copy and Paste/PasteSpecial to preserve cell formats, row heights and column widths in the new workbooks.

Public Sub Copy_Each_Page_Break_Section_To_New_Workbook()

    Dim dataWorksheet As Worksheet
    Dim saveActiveCell As Range
    Dim saveInFolder As String
    Dim originalView As XlWindowView
    Dim lastRow As Long, pageStartRow As Long
    Dim page As Long
    
    saveInFolder = ActiveWorkbook.Path & "\"
    
    'Look on the active sheet in the active workbook
    
    Set dataWorksheet = ActiveWorkbook.ActiveSheet
    Set saveActiveCell = ActiveCell
    
    Application.ScreenUpdating = False
    
    'Save current view and change it to Page Break Preview
    
    With ActiveWindow
        originalView = .View
        .View = xlPageBreakPreview
    End With
    
    With dataWorksheet
    
        lastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row        
        pageStartRow = 1
        
        'Copy rows before each page break to a new workbook
        
        For page = 1 To .HPageBreaks.Count
            Copy_Page_Rows_To_New_Workbook page, dataWorksheet, pageStartRow, dataWorksheet.HPageBreaks(page).Location.Row - 1, saveInFolder & "Workbook " & page & ".xlsx"
            pageStartRow = .HPageBreaks(page).Location.Row
        Next
    
        'Copy rows after last page break, if any, to a new workbook
        
        If pageStartRow <= lastRow Then
            Copy_Page_Rows_To_New_Workbook page, dataWorksheet, pageStartRow, lastRow, saveInFolder & "Workbook " & page & ".xlsx"
        End If
    
    End With
    
    'Restore original view
    
    ActiveWindow.View = originalView
    
    'Restore active cell
    
    dataWorksheet.Activate
    saveActiveCell.Select
    
    Application.ScreenUpdating = True

    MsgBox "Done"
    
End Sub


Private Sub Copy_Page_Rows_To_New_Workbook(page As Long, dataWorksheet As Worksheet, pageStartRow As Long, pageEndRow As Long, newWorkbookFullName As String)
    
    Dim newWorkbook As Workbook
    
    Set newWorkbook = Workbooks.Add(xlWBATWorksheet)
    
    With newWorkbook.Worksheets(1)
        .Name = dataWorksheet.Name
        If page = 1 Then
            'First page, so copy rows for page 1, which include rows 1:2, to destination sheet
            dataWorksheet.Rows(pageStartRow & ":" & pageEndRow).Copy .Range("A1")
            dataWorksheet.Rows(pageStartRow & ":" & pageEndRow).Copy
            With .Range("A1")
                .Select
                .Worksheet.Paste
                .PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            End With
        Else
            'Subsequent page, so copy rows 1:2 to destination sheet, followed by the rows for this page
            dataWorksheet.Rows("1:2").Copy .Range("A1")
            dataWorksheet.Rows("1:2").Copy
            With .Range("A1")
                .Select
                .Worksheet.Paste
                .PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            End With
            dataWorksheet.Rows(pageStartRow & ":" & pageEndRow).Copy .Range("A3")
        End If
        .Range("A1").Select
    End With
        
    Application.DisplayAlerts = False 'suppress warning if file exists
    newWorkbook.SaveAs newWorkbookFullName, FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    newWorkbook.Close False
                
End Sub

 

[UT_CL]

Try this macro, which copies the rows using Copy and Paste/PasteSpecial to preserve cell formats, row heights and column widths in the new workbooks.

Public Sub Copy_Each_Page_Break_Section_To_New_Workbook()

    Dim dataWorksheet As Worksheet
    Dim saveActiveCell As Range
    Dim saveInFolder As String
    Dim originalView As XlWindowView
    Dim lastRow As Long, pageStartRow As Long
    Dim page As Long
   
    saveInFolder = ActiveWorkbook.Path & "\"
   
    'Look on the active sheet in the active workbook
   
    Set dataWorksheet = ActiveWorkbook.ActiveSheet
    Set saveActiveCell = ActiveCell
   
    Application.ScreenUpdating = False
   
    'Save current view and change it to Page Break Preview
   
    With ActiveWindow
        originalView = .View
        .View = xlPageBreakPreview
    End With
   
    With dataWorksheet
   
        lastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row       
        pageStartRow = 1
       
        'Copy rows before each page break to a new workbook
       
        For page = 1 To .HPageBreaks.Count
            Copy_Page_Rows_To_New_Workbook page, dataWorksheet, pageStartRow, dataWorksheet.HPageBreaks(page).Location.Row - 1, saveInFolder & "Workbook " & page & ".xlsx"
            pageStartRow = .HPageBreaks(page).Location.Row
        Next
   
        'Copy rows after last page break, if any, to a new workbook
       
        If pageStartRow <= lastRow Then
            Copy_Page_Rows_To_New_Workbook page, dataWorksheet, pageStartRow, lastRow, saveInFolder & "Workbook " & page & ".xlsx"
        End If
   
    End With
   
    'Restore original view
   
    ActiveWindow.View = originalView
   
    'Restore active cell
   
    dataWorksheet.Activate
    saveActiveCell.Select
   
    Application.ScreenUpdating = True

    MsgBox "Done"
   
End Sub


Private Sub Copy_Page_Rows_To_New_Workbook(page As Long, dataWorksheet As Worksheet, pageStartRow As Long, pageEndRow As Long, newWorkbookFullName As String)
   
    Dim newWorkbook As Workbook
   
    Set newWorkbook = Workbooks.Add(xlWBATWorksheet)
   
    With newWorkbook.Worksheets(1)
        .Name = dataWorksheet.Name
        If page = 1 Then
            'First page, so copy rows for page 1, which include rows 1:2, to destination sheet
            dataWorksheet.Rows(pageStartRow & ":" & pageEndRow).Copy .Range("A1")
            dataWorksheet.Rows(pageStartRow & ":" & pageEndRow).Copy
            With .Range("A1")
                .Select
                .Worksheet.Paste
                .PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            End With
        Else
            'Subsequent page, so copy rows 1:2 to destination sheet, followed by the rows for this page
            dataWorksheet.Rows("1:2").Copy .Range("A1")
            dataWorksheet.Rows("1:2").Copy
            With .Range("A1")
                .Select
                .Worksheet.Paste
                .PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            End With
            dataWorksheet.Rows(pageStartRow & ":" & pageEndRow).Copy .Range("A3")
        End If
        .Range("A1").Select
    End With
       
    Application.DisplayAlerts = False 'suppress warning if file exists
    newWorkbook.SaveAs newWorkbookFullName, FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    newWorkbook.Close False
               
End Sub

Thank you! Thank you John! It worked seamlessly. I'm very new to VBA so this is way more advance than what I was trying to do on my own.

 

[UT_CL]

What can I do to change the Save File Name to what is in cell A4 of each workbook and today's date instead of Workbook 1, Workbook 2 and so? It should save the file as 'Cell A4 today's date' (Ex. ABC 04.18.24).

I was able to add the date part by inputting "Dim dDate As String" and "dDate = Format(Now, "mm.dd.yy")". Then, change "saveInFolder & "Workbook " & page & dDate & ".xlsx". But, I want to remove "Workbook & page" and replace it with whatever title is in cell A4. Thanks for any help in advance.

 

[John_w]

What can I do to change the Save File Name to what is in cell A4 of each workbook and today's date instead of Workbook 1, Workbook 2 and so? It should save the file as 'Cell A4 today's date' (Ex. ABC 04.18.24).

Replace the whole Copy_Page_Rows_To_New_Workbook routine with:

Private Sub Copy_Page_Rows_To_New_Workbook(page As Long, dataWorksheet As Worksheet, pageStartRow As Long, pageEndRow As Long, newWorkbookFolder As String)
    
    Dim newWorkbook As Workbook
    Dim filename As String
    
    Set newWorkbook = Workbooks.Add(xlWBATWorksheet)
    
    With newWorkbook.Worksheets(1)
        .Name = dataWorksheet.Name
        If page = 1 Then
            'First page, so copy rows for page 1, which include rows 1:2, to destination sheet
            dataWorksheet.Rows(pageStartRow & ":" & pageEndRow).Copy .Range("A1")
            dataWorksheet.Rows(pageStartRow & ":" & pageEndRow).Copy
            With .Range("A1")
                .Select
                .Worksheet.Paste
                .PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            End With
        Else
            'Subsequent page, so copy rows 1:2 to destination sheet, followed by the rows for this page
            dataWorksheet.Rows("1:2").Copy .Range("A1")
            dataWorksheet.Rows("1:2").Copy
            With .Range("A1")
                .Select
                .Worksheet.Paste
                .PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            End With
            dataWorksheet.Rows(pageStartRow & ":" & pageEndRow).Copy .Range("A3")
        End If
        .Range("A1").Select
        filename = .Range("A4").Value & Format(Date, " mm.dd.yy") & ".xlsx"
    End With
        
    Application.DisplayAlerts = False 'suppress warning if file exists
    newWorkbook.SaveAs newWorkbookFolder & filename, FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    newWorkbook.Close False
                
End Sub

And change the call to it with this:

            Copy_Page_Rows_To_New_Workbook page, dataWorksheet, pageStartRow, dataWorksheet.HPageBreaks(page).Location.Row - 1, saveInFolder

 

[UT_CL]

Replace the whole Copy_Page_Rows_To_New_Workbook routine with:

Private Sub Copy_Page_Rows_To_New_Workbook(page As Long, dataWorksheet As Worksheet, pageStartRow As Long, pageEndRow As Long, newWorkbookFolder As String)
   
    Dim newWorkbook As Workbook
    Dim filename As String
   
    Set newWorkbook = Workbooks.Add(xlWBATWorksheet)
   
    With newWorkbook.Worksheets(1)
        .Name = dataWorksheet.Name
        If page = 1 Then
            'First page, so copy rows for page 1, which include rows 1:2, to destination sheet
            dataWorksheet.Rows(pageStartRow & ":" & pageEndRow).Copy .Range("A1")
            dataWorksheet.Rows(pageStartRow & ":" & pageEndRow).Copy
            With .Range("A1")
                .Select
                .Worksheet.Paste
                .PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            End With
        Else
            'Subsequent page, so copy rows 1:2 to destination sheet, followed by the rows for this page
            dataWorksheet.Rows("1:2").Copy .Range("A1")
            dataWorksheet.Rows("1:2").Copy
            With .Range("A1")
                .Select
                .Worksheet.Paste
                .PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            End With
            dataWorksheet.Rows(pageStartRow & ":" & pageEndRow).Copy .Range("A3")
        End If
        .Range("A1").Select
        filename = .Range("A4").Value & Format(Date, " mm.dd.yy") & ".xlsx"
    End With
       
    Application.DisplayAlerts = False 'suppress warning if file exists
    newWorkbook.SaveAs newWorkbookFolder & filename, FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    newWorkbook.Close False
               
End Sub

And change the call to it with this:

            Copy_Page_Rows_To_New_Workbook page, dataWorksheet, pageStartRow, dataWorksheet.HPageBreaks(page).Location.Row - 1, saveInFolder

Wow I appreciate your assistance, John! Did not know the date can be done this way. This is way easier.