Ensure text box alway remains between page break

[Paulo H]

Hi I have a sheet with a table which is populated via a list box and works well. When the data from the list box is transfers to the table the table auto expands and adds row as expected. Below this I have a textbox with term and conditions in and when the table expands the list box moves down the sheet fine. However when it reaches a page break, the break cut across the text box and splits over two pages. What I require is all of the textbox to be all on one page. I have set in a row and set the properties to move and size and this works if I insert Via right click etc but not when table expand via list box entry. It moves down the table then to the next row leaving the original cell row too big and not resizing new row. Cheers

 

[pbornemeier]

This code will move a TextBox that is on a Horizontal Page Break so its top is at the Horizontal Page Break

Option Explicit

Sub MoveTextboxOnPageBreak()

    Dim aryBreaks As Variant
    Const sTextBoxName As String = "Textbox 2"
    Dim lTopLeftRow As Long
    Dim lBottomRightRow As Long
    Dim lIndex As Long
    Dim lHBCount As Long
    Dim lHBRow As Long
    
    Dim x
    
    With ActiveSheet
        Set x = .Shapes("TEXTBOX 2")
        .DisplayPageBreaks = True
        aryBreaks = GetHorizPageBreaks
        lHBCount = UBound(aryBreaks)
        If lHBCount > 1 Then
            'Might have to move box
            lTopLeftRow = .Shapes("Textbox 2").TopLeftCell.Row
            lBottomRightRow = .Shapes("Textbox 2").BottomRightCell.Row
            For lIndex = 2 To lHBCount
                lHBRow = aryBreaks(lIndex)
                If lTopLeftRow < lHBRow And lBottomRightRow + 1 > lHBRow Then
                    'Horizontal Break is between top and bottom of textbox
                    .Shapes("Textbox 2").Top = .Cells(lHBRow, 1).Top
                    Exit For
                End If
            Next
        Else
            'No horizontal break yet
        End If
    End With

End Sub

Function GetHorizPageBreaks()
    'Return existing horizontal page breaks on the active sheet
    
    Dim HPBrk As HPageBreak
    Dim sType As String
    Dim aryHBreaks As Variant
    Dim lIndex As Long
    'Note Automatic page breaks do not exist unless there is text that reqires them
    
    With ActiveSheet
        If .HPageBreaks.Count > 0 Then
            ReDim aryHBreaks(1 To .HPageBreaks.Count + 1)
            aryHBreaks(1) = 1
            lIndex = 1
            For Each HPBrk In .HPageBreaks
                lIndex = lIndex + 1
                'First row on new page
                aryHBreaks(lIndex) = HPBrk.Location.Row
            Next
        Else
            ReDim aryHBreaks(1 To 1)
            aryHBreaks(1) = 1
        End If
    End With
    
    GetHorizPageBreaks = aryHBreaks

End Function

 

[Paulo H]

This code will move a TextBox that is on a Horizontal Page Break so its top is at the Horizontal Page Break

Option Explicit

Sub MoveTextboxOnPageBreak()

    Dim aryBreaks As Variant
    Const sTextBoxName As String = "Textbox 2"
    Dim lTopLeftRow As Long
    Dim lBottomRightRow As Long
    Dim lIndex As Long
    Dim lHBCount As Long
    Dim lHBRow As Long
   
    Dim x
   
    With ActiveSheet
        Set x = .Shapes("TEXTBOX 2")
        .DisplayPageBreaks = True
        aryBreaks = GetHorizPageBreaks
        lHBCount = UBound(aryBreaks)
        If lHBCount > 1 Then
            'Might have to move box
            lTopLeftRow = .Shapes("Textbox 2").TopLeftCell.Row
            lBottomRightRow = .Shapes("Textbox 2").BottomRightCell.Row
            For lIndex = 2 To lHBCount
                lHBRow = aryBreaks(lIndex)
                If lTopLeftRow < lHBRow And lBottomRightRow + 1 > lHBRow Then
                    'Horizontal Break is between top and bottom of textbox
                    .Shapes("Textbox 2").Top = .Cells(lHBRow, 1).Top
                    Exit For
                End If
            Next
        Else
            'No horizontal break yet
        End If
    End With

End Sub

Function GetHorizPageBreaks()
    'Return existing horizontal page breaks on the active sheet
   
    Dim HPBrk As HPageBreak
    Dim sType As String
    Dim aryHBreaks As Variant
    Dim lIndex As Long
    'Note Automatic page breaks do not exist unless there is text that reqires them
   
    With ActiveSheet
        If .HPageBreaks.Count > 0 Then
            ReDim aryHBreaks(1 To .HPageBreaks.Count + 1)
            aryHBreaks(1) = 1
            lIndex = 1
            For Each HPBrk In .HPageBreaks
                lIndex = lIndex + 1
                'First row on new page
                aryHBreaks(lIndex) = HPBrk.Location.Row
            Next
        Else
            ReDim aryHBreaks(1 To 1)
            aryHBreaks(1) = 1
        End If
    End With
   
    GetHorizPageBreaks = aryHBreaks

End Function

Thanks for this but not sure if I am setting it wrong I am adding it to the main worksheet but the text box which has the info in still straddles the page break when items are inserted into my table

 

[pbornemeier]

My original code was for Excel 2010. It worked in that version. It failed when I tried to run it in Excel 2016.
I added a version checker that used that code for versions less that Excel 2016 and a different code for Excel 2016 and later. I therefore assumed that Excel 2013 would be happy with the 2020 version. This may not be the case.

I also used the sTextBoxName constant properly instead of having the hard coded name of the textbox in 5 different places.

If you are running Excel 2013 this might still error out.
Try the following code and let me know how it works and if there is a problem what version of Excel you are running.

Be sure to replace Textbox 2 in the following line in 'Sub MoveTextboxOnPageBreak' to the name of the Textbox you are using.

Const sTextBoxName As String = "Textbox 2" 'Change Textbox 2 to the name of the textbox that you want to keep off of the page break

Option Explicit

Sub MoveTextboxOnPageBreak()

    Dim aryBreaks As Variant
    Const sTextBoxName As String = "Textbox 2"  'Change Textbox 2 to the name of the textbox that you want to keep off of the page break
    Dim lTopLeftRow As Long
    Dim lBottomRightRow As Long
    Dim lIndex As Long
    Dim lHBCount As Long
    Dim lHBRow As Long
    
    Dim x
    
    With ActiveSheet
        Set x = .Shapes(sTextBoxName)
        .DisplayPageBreaks = True
        aryBreaks = GetHorizPageBreaks
        lHBCount = UBound(aryBreaks)
        If lHBCount > 1 Then
            'Might have to move box
            lTopLeftRow = .Shapes(sTextBoxName).TopLeftCell.Row
            lBottomRightRow = .Shapes(sTextBoxName).BottomRightCell.Row
            For lIndex = 2 To lHBCount
                lHBRow = aryBreaks(lIndex)
                If lTopLeftRow < lHBRow And lBottomRightRow + 1 > lHBRow Then
                    'Horizontal Break is between top and bottom of textbox
                    .Shapes(sTextBoxName).Top = .Cells(lHBRow, 1).Top
                    Exit For
                End If
            Next
        Else
            'No horizontal break yet
        End If
    End With

End Sub

Function GetHorizPageBreaks()
    'Return existing horizontal page breaks on the active sheet
    
    Dim HPBrk As HPageBreak
    Dim sType As String
    Dim aryHBreaks As Variant
    Dim lIndex As Long
    'Note Automatic page breaks do not exist unless there is text that requires them
    
    With ActiveSheet
        If .HPageBreaks.Count > 0 Then
            ReDim aryHBreaks(1 To .HPageBreaks.Count + 1)
            aryHBreaks(1) = 1
             If Val(Application.Version) < 16 Then
                'Excel 2010
                For Each HPBrk In .HPageBreaks
                    lIndex = lIndex + 1
                    'First row on new page
                    aryHBreaks(lIndex) = HPBrk.Location.Row
                Next
            Else
                'Excel 2016
                For lIndex = 2 To UBound(aryHBreaks)
                    aryHBreaks(lIndex) = .HPageBreaks(lIndex - 1).Location.Row
                Next
            End If
        Else
            ReDim aryHBreaks(1 To 1)
            aryHBreaks(1) = 1
        End If
    End With
    
    GetHorizPageBreaks = aryHBreaks

End Function

 

[Paulo H]

My original code was for Excel 2010. It worked in that version. It failed when I tried to run it in Excel 2016.
I added a version checker that used that code for versions less that Excel 2016 and a different code for Excel 2016 and later. I therefore assumed that Excel 2013 would be happy with the 2020 version. This may not be the case.

I also used the sTextBoxName constant properly instead of having the hard coded name of the textbox in 5 different places.

If you are running Excel 2013 this might still error out.
Try the following code and let me know how it works and if there is a problem what version of Excel you are running.

Be sure to replace Textbox 2 in the following line in 'Sub MoveTextboxOnPageBreak' to the name of the Textbox you are using.

Const sTextBoxName As String = "Textbox 2" 'Change Textbox 2 to the name of the textbox that you want to keep off of the page break

Option Explicit

Sub MoveTextboxOnPageBreak()

    Dim aryBreaks As Variant
    Const sTextBoxName As String = "Textbox 2"  'Change Textbox 2 to the name of the textbox that you want to keep off of the page break
    Dim lTopLeftRow As Long
    Dim lBottomRightRow As Long
    Dim lIndex As Long
    Dim lHBCount As Long
    Dim lHBRow As Long
   
    Dim x
   
    With ActiveSheet
        Set x = .Shapes(sTextBoxName)
        .DisplayPageBreaks = True
        aryBreaks = GetHorizPageBreaks
        lHBCount = UBound(aryBreaks)
        If lHBCount > 1 Then
            'Might have to move box
            lTopLeftRow = .Shapes(sTextBoxName).TopLeftCell.Row
            lBottomRightRow = .Shapes(sTextBoxName).BottomRightCell.Row
            For lIndex = 2 To lHBCount
                lHBRow = aryBreaks(lIndex)
                If lTopLeftRow < lHBRow And lBottomRightRow + 1 > lHBRow Then
                    'Horizontal Break is between top and bottom of textbox
                    .Shapes(sTextBoxName).Top = .Cells(lHBRow, 1).Top
                    Exit For
                End If
            Next
        Else
            'No horizontal break yet
        End If
    End With

End Sub

Function GetHorizPageBreaks()
    'Return existing horizontal page breaks on the active sheet
   
    Dim HPBrk As HPageBreak
    Dim sType As String
    Dim aryHBreaks As Variant
    Dim lIndex As Long
    'Note Automatic page breaks do not exist unless there is text that requires them
   
    With ActiveSheet
        If .HPageBreaks.Count > 0 Then
            ReDim aryHBreaks(1 To .HPageBreaks.Count + 1)
            aryHBreaks(1) = 1
             If Val(Application.Version) < 16 Then
                'Excel 2010
                For Each HPBrk In .HPageBreaks
                    lIndex = lIndex + 1
                    'First row on new page
                    aryHBreaks(lIndex) = HPBrk.Location.Row
                Next
            Else
                'Excel 2016
                For lIndex = 2 To UBound(aryHBreaks)
                    aryHBreaks(lIndex) = .HPageBreaks(lIndex - 1).Location.Row
                Next
            End If
        Else
            ReDim aryHBreaks(1 To 1)
            aryHBreaks(1) = 1
        End If
    End With
   
    GetHorizPageBreaks = aryHBreaks

End Function

H thanks again for your help

It still doesn't appear to work but it may be me

I am using excel 2016. The text box was created on the main sheet using excel insert then text box but this doesn't appear to give a name i.e "text box 2" the only option I have is set as default text box. Also could it have something to do with the table I have as the problem occurs when I add a row to the table. the textbox is being used to add terms and conditions to a quote and the table is the quote which of course expands when items are inserted. therefore when the final form is done and viewed the textbox is split over two pages. Not a real problem but I would prefer if it was moved to separate page. Thanks again

 

[Yongle]

Butting in briefly ....

It still doesn't appear to work but it may be me

Yes

Right click on the text box to select it
Name appears in the Name Box
Name Box is the box above cell A1

This may also help
- code below lists names of shapes in active sheet

Sub LoopShapes()
    Dim shp As Shape, msg As String
    For Each shp In ActiveSheet.Shapes
        msg = msg & vbCr & shp.TopLeftCell.Address(0, 0) & vbTab & shp.Name
    Next
    MsgBox msg
End Sub

 

[Paulo H]

Butting in briefly ....


Yes

Right click on the text box to select it
Name appears in the Name Box
Name Box is the box above cell A1

This may also help
- code below lists names of shapes in active sheet

Sub LoopShapes()
    Dim shp As Shape, msg As String
    For Each shp In ActiveSheet.Shapes
        msg = msg & vbCr & shp.TopLeftCell.Address(0, 0) & vbTab & shp.Name
    Next
    MsgBox msg
End Sub

Hi that was very helpfulit is textbox 2!

 

[Paulo H]

H thanks again for your help

It still doesn't appear to work but it may be me

I am using excel 2016. The text box was created on the main sheet using excel insert then text box but this doesn't appear to give a name i.e "text box 2" the only option I have is set as default text box. Also could it have something to do with the table I have as the problem occurs when I add a row to the table. the textbox is being used to add terms and conditions to a quote and the table is the quote which of course expands when items are inserted. therefore when the final form is done and viewed the textbox is split over two pages. Not a real problem but I would prefer if it was moved to separate page. Thanks again

Btw it is text box 2. I pressume I shout be adding this to the main worksheet?

 

[pbornemeier]

Find the name of the textbox that is on your worksheet using the method that Yongle described

Right click on the text box to select it
Name appears in the Name Box
Name Box is the box above cell A1

then in my code from post #5 (which is copied to the code page of the worksheet that contains the textbox) replace Textbox 2 in this line:

Const sTextBoxName As String = "Textbox 2"

with the name of your textbox.

The code will move the textbox when it is run. It will not run automatically. You could call it from a print subroutine a worksheet event or trigger it manually.