Excel VBA conditional insert of page breaks


New Member
Oct 16, 2018
I have a form that is changing all the time according to my "Filling form" where user is filling in information. Then I have "Print version" sheet for autoformatting and printing to .pdf/.xls. In "Print version" I have paragraphs of text in column "C". Some cells with text of column "C" are too long so I am wrapping them with my VBA (.WrapText = True). I want to make conditional page breaks that will read through my Print Area and insert page breaks after each empty row after each paragraph that is not fitting to page compleatly. My VBA code below is working fine except for text being wrapped. If I remove all cells with "Wrap text" command each row have some constant height, let's say 15 so I know amount of rows could be fitted on the page and set my "PgSize = 91" or whatever it is but if I wrap text I don't know how many rows can be fitted on the page. So the problem is: If I set "PgSize = 91" in "Sub FitGroupsToPage()" (that's an amount of rows could be fitted to each page) to 91 and don't wrap my text then everything works fine. However text must be wrapped to fit to my page vertically. Then there is not 91 rows but less, depending on the length of the text in wrapped cells. So number 91 is dynamic each time after hiding and wrapping "Sub FitMyTextPlease()" and "Sub HideMyEmptyRows()" and "Sub SetPrintArea()". Number of rows can also be different on every page (depending of how much text there are in wrapped cells on each page). Any ideas of how this issue can be fixed or maybe suggest some other way of approaching this?

Sub FitMyTextPlease()
   Application.ScreenUpdating = False
    ThisWorkbook.Sheets("Print version").PageSetup.CenterHeader = "&""Times New Roman,Bold""&12 " & Range("Data!V28").Text & Chr(13) & Chr(13) & " " & "&""Times New Roman,Normal""&12 " & Range("Data!V30").Text
    'ThisWorkbook.Sheets("Print version").PageSetup.CenterHeader = Range("Data!V28").Text

    ThisWorkbook.Sheets("Print version").Select
    With ActiveWorkbook.ActiveSheet
            With .Cells.Rows
                .WrapText = True
                .VerticalAlignment = xlCenter
            End With '.Cells.Rows
        End With 'sheet
        Application.ScreenUpdating = True
End Sub
Sub HideMyEmptyRows()
    Dim myRange As Range
    Dim cell As Range
    Application.ScreenUpdating = False
    Set myRange = ThisWorkbook.Sheets("Print version").Range("Print_Area")
        For Each cell In myRange
        myRange.Interior.ColorIndex = 0
        If cell.HasFormula = True And cell.value = "" And cell.EntireRow.Hidden = False Then Rows(cell.Row).EntireRow.Hidden = True
    Application.ScreenUpdating = True
End Sub
Sub SetPrintArea()
  Dim ws As Worksheet
  Dim lastRow As Long

  Set ws = ThisWorkbook.Sheets("Print version")

  ' find the last row with formatting, to be included in print range
  lastRow = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row

  ws.PageSetup.PrintArea = ws.Range("A1:C" & lastRow).Address
End Sub
Sub HowManyPagesBreaks22()
    Dim iHpBreaks As Integer, iVBreaks As Integer
    Dim iTotPages As Integer

    iHpBreaks = ActiveSheet.HPageBreaks.Count + 1
    iVBreaks = ActiveSheet.VPageBreaks.Count + 1

    iTotPages = iHpBreaks * iVBreaks
    MsgBox "This sheet will require " & iTotPages & _
    " page(s) to print", vbInformation, "Pages counted"
End Sub
Sub Printed_Pages_Count()
    Range("A1").value = (ActiveSheet.HPageBreaks.Count + 1) * (ActiveSheet.VPageBreaks.Count + 1)
End Sub
Sub HowManyPagesBreaks()

    MsgBox ExecuteExcel4Macro("Get.Document(50)")

End Sub
Sub FitGroupsToPage()
    Dim rStart As Range, rEnd As Range, TestCell As Range
    Dim lastRow As Long, PgSize As Integer
    Dim n As Integer
    PgSize = 91   '  Assumes 91 rows per page
    Set rStart = Range("C1")
    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
        Set TestCell = rStart.Offset(PgSize, 0)
        If Len(TestCell) = 0 Or Len(TestCell.Offset(-1, 0)) = 0 Then
                Set rEnd = TestCell.End(xlUp)
                Set rEnd = TestCell.End(xlUp).End(xlUp)
        End If
        ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=rEnd.Offset(1, 0)
        Set rStart = rEnd.Offset(1, 0)
    n = n + 1
    If n > 1000 Then Exit Sub   '  Escapes from an infinite loop if code fails
    Loop Until rStart.Row > lastRow - 50
End Sub
Sub FitMyHeadings()
Call FitMyTextPlease
Call HideMyEmptyRows
Call SetPrintArea
Call FitGroupsToPage
Call Printed_Pages_Count
End Sub

Some videos you may like

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).


New Member
Oct 16, 2018
Problem is that paragraphs are not every 10th or 15th or 18th row. There are can be different amount of paragraphs and rows in each paragraph. They always have a "heading" so maybe it can help somehow. Bold text with heading and then paragraph itself. This complete "block" should be on one page and if it doesn't fit to this page then VBA code should move it to the next page.



Watch MrExcel Video

Forum statistics

Latest member

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back