dcsimg
Results 1 to 12 of 12

Thread: Excel VBA conditional insert of page breaks

  1. #1

    Thread Starter
    New Member
    Join Date
    Oct 2018
    Posts
    10

    Excel VBA conditional insert of page breaks

    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?


    Code:
    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
                    .EntireRow.AutoFit
                End With '.Cells.Rows
                .Columns.EntireColumn.AutoFit
            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
        Next
        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
        
        Do
            Set TestCell = rStart.Offset(PgSize, 0)
            If Len(TestCell) = 0 Or Len(TestCell.Offset(-1, 0)) = 0 Then
                    Set rEnd = TestCell.End(xlUp)
                Else
                    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

  2. #2
    Super Moderator si_the_geek's Avatar
    Join Date
    Jul 2002
    Location
    Bristol, UK
    Posts
    40,280

    Re: Excel VBA conditional insert of page breaks

    Welcome to VBForums

    Thread moved from the 'VB.Net' forum to the 'Office Development/VBA' forum.

  3. #3

    Thread Starter
    New Member
    Join Date
    Oct 2018
    Posts
    10

    Re: Excel VBA conditional insert of page breaks

    You can download file here: https://files.fm/u/78q4zy6w

    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.
    Attached Images Attached Images   

  4. #4
    PowerPoster
    Join Date
    Dec 2004
    Posts
    23,819

    Re: Excel VBA conditional insert of page breaks

    i had some success testing this code
    Code:
    Dim sh As Worksheet, fnd As Range, r As Range, pb As HPageBreak
    Set sh = Sheets("Print version")
    For Each pb In sh.HPageBreaks
        Set r = sh.Cells(pb.Location.Row, 2)
        Set fnd = sh.Range("b:b").Find("*", r, , , , xlPrevious)
        If Not Intersect(fnd.Offset(, -1).Resize(fnd.Offset(, 1).End(xlDown).Row - fnd.Row + 1, 5), r) Is Nothing Then
            Set pb.Location = fnd
        End If
    Next
    note to move page breaks you need the sheet to be in pagebreak view, you can change the view by code
    i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
    Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next

    dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part

    come back and mark your original post as resolved if your problem is fixed
    pete

  5. #5

    Thread Starter
    New Member
    Join Date
    Oct 2018
    Posts
    10

    Re: Excel VBA conditional insert of page breaks

    Quote Originally Posted by westconn1 View Post
    i had some success testing this code
    Code:
    Dim sh As Worksheet, fnd As Range, r As Range, pb As HPageBreak
    Set sh = Sheets("Print version")
    For Each pb In sh.HPageBreaks
        Set r = sh.Cells(pb.Location.Row, 2)
        Set fnd = sh.Range("b:b").Find("*", r, , , , xlPrevious)
        If Not Intersect(fnd.Offset(, -1).Resize(fnd.Offset(, 1).End(xlDown).Row - fnd.Row + 1, 5), r) Is Nothing Then
            Set pb.Location = fnd
        End If
    Next
    note to move page breaks you need the sheet to be in pagebreak view, you can change the view by code
    Thank you for your effort! I have been testing your code with no success. For some reason your code does not do anything. Is it possible to upload file with working code, maybe I can get it working this way?

  6. #6
    Fanatic Member dmaruca's Avatar
    Join Date
    May 2006
    Location
    Jacksonville, FL
    Posts
    570

    Re: Excel VBA conditional insert of page breaks

    Hey, you should use row height. It will give you a more accurate measurement. Row height is measured in points which is 72 points her inch height and 12 points per inch width. Then you no longer have to make an assumption of how many rows will fit. Here's some code to get you started. I tested this code and it works to what I think you want. I used A4 paper height since that's what you had set.

    Note that you must be in page payout view to see the changes. Page break preview will not update to show you the changes.

    Code:
    Sub FitGroupsToPage()
        Dim lastRow As Long
        Dim row As Long 'always make a row counting variable a long. integer is too short
        Dim sht As Worksheet
        Dim marginHeight As Double
        Dim maxHeight As Double
        Dim curHeight As Double
        Dim vals As Variant
        Dim rng As Range
        Dim lastEmptyRow As Long 'holds the row that was last empty
        
        Set sht = Worksheets("Print Version")
        sht.ResetAllPageBreaks
        
        'read margin height
        marginHeight = sht.PageSetup.TopMargin + sht.PageSetup.BottomMargin
        maxHeight = Application.InchesToPoints(11.69) 'assumes A4 paper height. you can enumerate sht.PageSetup.PaperSize to make it more dynamic
        
        lastRow = sht.UsedRange.Rows.Count
        
        'read cells into a (row,col) array. much faster than looping through ranges. usually no memory issues with reading only one column.
        Set rng = sht.Range(sht.Cells(1, 3), sht.Cells(lastRow, 3))
        vals = rng.Value 'vals will hold a 2D array, but only one column which is C.
        
        lastEmptyRow = 1
        curHeight = marginHeight
        For row = 1 To lastRow
            If vals(row, 1) = 0 Then
                lastEmptyRow = row
            End If
            curHeight = curHeight + sht.Rows(row).Height
            If curHeight > maxHeight Then
                sht.HPageBreaks.Add Before:=sht.Cells(lastEmptyRow + 1, 3)
                curHeight = marginHeight
            End If
            
        Next
        
    End Sub

  7. #7

    Thread Starter
    New Member
    Join Date
    Oct 2018
    Posts
    10

    Re: Excel VBA conditional insert of page breaks

    Quote Originally Posted by dmaruca View Post
    Hey, you should use row height. It will give you a more accurate measurement. Row height is measured in points which is 72 points her inch height and 12 points per inch width. Then you no longer have to make an assumption of how many rows will fit. Here's some code to get you started. I tested this code and it works to what I think you want. I used A4 paper height since that's what you had set.

    Note that you must be in page payout view to see the changes. Page break preview will not update to show you the changes.

    Code:
    Sub FitGroupsToPage()
        Dim lastRow As Long
        Dim row As Long 'always make a row counting variable a long. integer is too short
        Dim sht As Worksheet
        Dim marginHeight As Double
        Dim maxHeight As Double
        Dim curHeight As Double
        Dim vals As Variant
        Dim rng As Range
        Dim lastEmptyRow As Long 'holds the row that was last empty
        
        Set sht = Worksheets("Print Version")
        sht.ResetAllPageBreaks
        
        'read margin height
        marginHeight = sht.PageSetup.TopMargin + sht.PageSetup.BottomMargin
        maxHeight = Application.InchesToPoints(11.69) 'assumes A4 paper height. you can enumerate sht.PageSetup.PaperSize to make it more dynamic
        
        lastRow = sht.UsedRange.Rows.Count
        
        'read cells into a (row,col) array. much faster than looping through ranges. usually no memory issues with reading only one column.
        Set rng = sht.Range(sht.Cells(1, 3), sht.Cells(lastRow, 3))
        vals = rng.Value 'vals will hold a 2D array, but only one column which is C.
        
        lastEmptyRow = 1
        curHeight = marginHeight
        For row = 1 To lastRow
            If vals(row, 1) = 0 Then
                lastEmptyRow = row
            End If
            curHeight = curHeight + sht.Rows(row).Height
            If curHeight > maxHeight Then
                sht.HPageBreaks.Add Before:=sht.Cells(lastEmptyRow + 1, 3)
                curHeight = marginHeight
            End If
            
        Next
        
    End Sub
    Thank you very much! I was testing this code for some time with no success. Now I thought that maybe the problem is that I am in Europe and we use cm instead of inches here? One cell is 0,51 cm at least I get this height in Page Layout preview (Row Height = 0,51cm). There are 46 standard rows can be fitted on one page. So page height is 46 x 0,51 cm = 23,46 cm. Can you please suggest how I should change the code to get it working in Europe with different measurement units? Thank you for your effort!

  8. #8
    Fanatic Member dmaruca's Avatar
    Join Date
    May 2006
    Location
    Jacksonville, FL
    Posts
    570

    Re: Excel VBA conditional insert of page breaks

    It shouldn't matter. All of the properties I'm using use points instead of inches or centimeters. I did test the code and it worked before posting.

    This is only the line you change to what you have your print paper set to. You can see other measurement conversions here: https://exceloffthegrid.com/vba-conv...els-to-points/

    Code:
    maxHeight = Application.InchesToPoints(11.69) 'assumes A4 paper height. you can enumerate sht.PageSetup.PaperSize to make it more dynamic

  9. #9
    PowerPoster
    Join Date
    Dec 2004
    Posts
    23,819

    Re: Excel VBA conditional insert of page breaks

    I thought that maybe the problem is that I am in Europe and we use cm instead of inches here?
    maxHeight = Application.InchesToPoints(11.69) 'assumes A4 paper height. you can enumerate sht.
    a4 sheet height 11.69 inches or 297mm less margins top and bottom about 245mm so the page size used in the code is basically the same as your spec, so i doubt that the different units is your problem
    if you are concerned about it try
    Code:
    maxheight = application.CentimetersToPoints(whatevertheheightofyourpaperincentimeters)
    i have not tested the code, so can not suggest why there is a problem
    i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
    Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next

    dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part

    come back and mark your original post as resolved if your problem is fixed
    pete

  10. #10
    PowerPoster
    Join Date
    Dec 2004
    Posts
    23,819

    Re: Excel VBA conditional insert of page breaks

    i reworked the code i posted previously to solve the error of any additional breaks causing some items to be missed
    on testing with your sample workbook, it worked correctly, without error, though i had not run any of your other formatting procedures

    Code:
    Dim sh As Worksheet, fnd As Range, r As Range, pb As Variant
    Set sh = Sheets("Print version")
    ' make sure sheet is in page break view
    sh.Parent.Windows(1).View = xlPageBreakPreview
    
    ' first clear any set page breaks
    On Error Resume Next
    For Each pb In sh.HPageBreaks
        pb.Delete
    Next
    On Error GoTo 0
    
    ' move preposed breaks to top of segement
    With sh.HPageBreaks
        For pb = 1 To .Count
            Set r = Cells(.Item(pb).Location.Row, 2)
            Set fnd = Range("b:b").Find("*", r, , , , xlPrevious)
            If Not Intersect(fnd.Offset(, -1).Resize(fnd.Offset(, 1).End(xlDown).Row - fnd.Row + 1, 5), r) Is Nothing Then
                Set .Item(pb).Location = fnd
                DoEvents
            End If
        Next
    End With
    i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
    Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next

    dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part

    come back and mark your original post as resolved if your problem is fixed
    pete

  11. #11

    Thread Starter
    New Member
    Join Date
    Oct 2018
    Posts
    10

    Re: Excel VBA conditional insert of page breaks

    Quote Originally Posted by westconn1 View Post
    i reworked the code i posted previously to solve the error of any additional breaks causing some items to be missed
    on testing with your sample workbook, it worked correctly, without error, though i had not run any of your other formatting procedures

    Code:
    Dim sh As Worksheet, fnd As Range, r As Range, pb As Variant
    Set sh = Sheets("Print version")
    ' make sure sheet is in page break view
    sh.Parent.Windows(1).View = xlPageBreakPreview
    
    ' first clear any set page breaks
    On Error Resume Next
    For Each pb In sh.HPageBreaks
        pb.Delete
    Next
    On Error GoTo 0
    
    ' move preposed breaks to top of segement
    With sh.HPageBreaks
        For pb = 1 To .Count
            Set r = Cells(.Item(pb).Location.Row, 2)
            Set fnd = Range("b:b").Find("*", r, , , , xlPrevious)
            If Not Intersect(fnd.Offset(, -1).Resize(fnd.Offset(, 1).End(xlDown).Row - fnd.Row + 1, 5), r) Is Nothing Then
                Set .Item(pb).Location = fnd
                DoEvents
            End If
        Next
    End With
    I have already started to think it is impossible to achieve and then you posted your code. You are true genius!
    Thanks to everyone for their effort! Quoted code worked for me with no problem! Programming rules! Wish I will gain my skills to that level someday.

  12. #12
    PowerPoster
    Join Date
    Dec 2004
    Posts
    23,819

    Re: Excel VBA conditional insert of page breaks

    Wish I will gain my skills to that level someday.
    forever learning, i had no idea to start, how it could be done
    i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
    Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next

    dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part

    come back and mark your original post as resolved if your problem is fixed
    pete

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width