Ron de Bruin
Excel Automation

Create separate sheet for each horizontal PageBreak

Important message to visitors of this page

Ron de Bruin decided to remove all Windows Excel content from his website for personal reasons. If you want to know why, head over to rondebruin.nl.

Luckily, Ron was kind enough to allow me to publish all of his Excel content here.

Most of these pages are slightly outdated and may contain links that don 't work. Please inform me if you find such an error and I'll try to fix it.

Kind regards

Jan Karel Pieterse

Copy the code in a Standard module of your workbook, if you just started with VBA see this page.
Where do I paste the code that I find on the internet

The macro below will copy the cells between each horizontal PageBreak in the ActiveSheet into a newly created worksheet. In the example I copy the cells from column A:K (you can change that)

Sub Create_Separate_Sheet_For_Each_HPageBreak()
    Dim HPB As HPageBreak
    Dim RW As Long
    Dim PageNum As Long
    Dim Asheet As Worksheet
    Dim Nsheet As Worksheet
    Dim Acell As Range

    'Sheet with the data, you can also use Sheets("Sheet1")
    Set Asheet = ActiveSheet

    If Asheet.HPageBreaks.Count = 0 Then
        MsgBox "There are no HPageBreaks"
        Exit Sub
    End If

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'When the macro is ready we return to this cell on the ActiveSheet
    Set Acell = Range("A1")

    'Because of this bug we select a cell below your data
    'http://support.microsoft.com/default.aspx?scid=kb;en-us;210663
    Application.Goto Asheet.Range("A" & Rows.Count), True

    RW = 1
    PageNum = 1

    For Each HPB In Asheet.HPageBreaks
        'Add a sheet for the page
        With Asheet.Parent
            Set Nsheet = Worksheets.Add(after:=.Sheets(.Sheets.Count))
        End With

        'Give the sheet a name
        On Error Resume Next
        Nsheet.Name = "Page " & PageNum
        If Err.Number > 0 Then
            MsgBox "Change the name of : " & Nsheet.Name & " manually"
            Err.Clear
        End If
        On Error GoTo 0

        'Copy the cells from the page into the new sheet
        With Asheet
            .Range(.Cells(RW, "A"), .Cells(HPB.Location.Row - 1, "K")).Copy _
                    Nsheet.Cells(1)
        End With
        ' If you want to make values of your formulas use this line also
        ' Nsheet.UsedRange.Value = Nsheet.UsedRange.Value

        RW = HPB.Location.Row
        PageNum = PageNum + 1
    Next HPB

    Asheet.DisplayPageBreaks = False
    Application.Goto Acell, True

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

If you only want to do this for manual Page Breaks then you can add two lines to the macro.

After For Each HPB In Asheet.HPageBreaks add this line
If HPB.Type = xlPageBreakManual Then

And before Next HPB add this line
End If

Copyright © 2022 Ron de Bruin

Site designed by Spider Web Woman Designs