Page Break VBA Help

[leila]

I have an Excel sheet with Column "A" containing Credit, Notes, and Tasks. They all have Heading 1 cell styles. The section for Credit ends on the row before Notes, and the end of the section for Tasks is the row before Credit. I want each section to remain together, so I would like to put a page break before the section if the page split the Credit, Notes, or Tasks. Additionally, if a Heading section is at the end of the page, I also want to put a page break to keep that section together. I have a lot of Credit, Notes, and Tasks, and some Credit sections which they are different. So I might have Credit on Page 1, 5, 6, 10, 11, 15, etc. as an example. Can anyone help me with that.

 

[leila]

 

[leila]

Here is the code but it is not working

Sub InsertPageBreaksDynamic()
On Error GoTo ErrorHandler

Dim ws As Worksheet
Dim currentRow As Long
Dim endOfCredit As Long
Dim endOfNotes As Long
Dim endOfTasks As Long
Dim remainingRows As Long
Dim nextPageStartRow As Long
Dim i As Long

' Specify the worksheet where you want to insert page breaks
Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to your sheet's name
' Clear existing page breaks
ws.ResetAllPageBreaks
' Adjust page size to 66%
ActiveSheet.PageSetup.Zoom = 66

' Start from the first row
currentRow = 1

Do
' Find the end of the "Credit" section
currentRow = FindNextHeaderRow(ws, currentRow, "Credit")
endOfCredit = FindEndOfSection(ws, currentRow, "Notes")

' Find the end of the "Notes" section
currentRow = FindNextHeaderRow(ws, currentRow, "Notes")
endOfNotes = FindEndOfSection(ws, currentRow, "Tasks")

' Find the end of the "Tasks" section
currentRow = FindNextHeaderRow(ws, currentRow, "Tasks")
endOfTasks = FindEndOfSection(ws, currentRow, "Credit")

' Calculate the remaining rows on the current page
remainingRows = RowsPerPage(ws, currentRow)

' Check if any of the sections extend beyond the current page
If endOfCredit > currentRow + remainingRows - 1 Or endOfNotes > currentRow + remainingRows - 1 Or endOfTasks > currentRow + remainingRows - 1 Then
' Determine the start of the next page
nextPageStartRow = ws.Cells(currentRow + remainingRows, "A").End(xlUp).Row + 1

' Move the sections to the next page if necessary
If currentRow <= endOfTasks And endOfTasks < nextPageStartRow Then
' Find the last row of the "Tasks" section
For i = endOfTasks + 1 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
If ws.Cells(i, "A").Value <> "" Then
endOfTasks = i - 1
Exit For
End If
Next i

' Add a page break before the start of the "Tasks" section on the next page
ws.HPageBreaks.Add Before:=ws.Cells(endOfTasks + 1, "A")
End If

If currentRow <= endOfNotes And endOfNotes < nextPageStartRow Then
' Find the last row of the "Notes" section
For i = endOfNotes + 1 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
If ws.Cells(i, "A").Value <> "" Then
endOfNotes = i - 1
Exit For
End If
Next i

' Add a page break before the start of the "Notes" section on the next page
ws.HPageBreaks.Add Before:=ws.Cells(endOfNotes + 1, "A")
End If

If currentRow <= endOfCredit And endOfCredit < nextPageStartRow Then
' Find the last row of the "Credit" section
For i = endOfCredit + 1 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
If ws.Cells(i, "A").Value <> "" Then
endOfCredit = i - 1
Exit For
End If
Next i

' Add a page break before the start of the "Credit" section on the next page
ws.HPageBreaks.Add Before:=ws.Cells(endOfCredit + 1, "A")
End If

' Update the current row to the next page start row
currentRow = nextPageStartRow
End If

' Move to the next row
currentRow = currentRow + 1
Loop Until currentRow > ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

Exit Sub

ErrorHandler:
MsgBox "An error occurred: " & Err.Description, vbExclamation
End Sub

Function FindNextHeaderRow(ws As Worksheet, currentRow As Long, headerText As String) As Long
' Find the next row containing the specified header text in column A
Dim headerRow As Range
Set headerRow = ws.Columns("A").Find(What:=headerText, After:=ws.Cells(currentRow, 1), LookIn:=xlValues, LookAt:=xlPart)
If Not headerRow Is Nothing Then
FindNextHeaderRow = headerRow.Row
Else
' If header not found, return the last row of the worksheet
FindNextHeaderRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
End If
End Function

Function FindEndOfSection(ws As Worksheet, currentRow As Long, sectionName As String) As Long
' Find the end of the section based on the next section header
Dim nextSectionRow As Long

' Loop through the rows to find the next section header or an empty cell
Do While currentRow <= ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
If ws.Cells(currentRow, 1).Style = "Heading 1" Then
If ws.Cells(currentRow, 1).Value = sectionName Then
' If next section header found, return the previous row as the end of the current section
FindEndOfSection = currentRow - 1
Exit Function
End If
ElseIf ws.Cells(currentRow, 1).Value = "" Then
' If an empty cell is found, return the previous row as the end of the current section
FindEndOfSection = currentRow - 1
Exit Function
End If
currentRow = currentRow + 1
Loop

' If next section header not found and there are no empty cells, return the last row of the worksheet
FindEndOfSection = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
End Function


Function RowsPerPage(ws As Worksheet, currentRow As Long) As Long
' Calculate the remaining rows on the current page
Dim lastRow As Long
Dim pageHeight As Double
Dim pageStart As Double

' Find the last row of the current page
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

' Get the height of the current page
pageStart = ws.Rows(currentRow).Top
pageHeight = ws.Rows(lastRow).Top - pageStart

' Calculate the number of rows that can fit in the remaining space on the current page
RowsPerPage = Application.WorksheetFunction.Floor((pageHeight + ws.Rows(currentRow).RowHeight) / ws.Rows(1).RowHeight, 1)
End Function