Resizing textbox based on the table height next to it.

[madvogue29]

Hi I have a few tables and a few textboxes next to the tables. I want the textboxes to expand when new rows are added to the table.
The range would be dynamic hence I have to find the textbox in the specified range and then adjust the height.
I tried to code it but the height of the textbox doesnt exactly match the height of the table. can someone please help ??


Sub ResizeBox1()
Dim sTL As String
Dim sBR As String
Dim r As Range
Dim shp As Shape

Set r = Range("A120:t182") ' These values would be dynamic later (I plan to get this as an input from another function)

' Change top-left and bottom-right addresses as desired
sTL = "P120" ' These values would be dynamic later
sBR = "d62" ' These values would be dynamic later

' Ensure a text box is selected
For Each shp In ActiveSheet.Shapes
If Not Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), r) Is Nothing Then _

With Selection
Set r = ActiveSheet.Range(sTL)
shp.Top = r.Top
shp.Left = r.Left
Set r = ActiveSheet.Range(sBR)
shp.Width = r.Left + r.Width
shp.Height = r.Top + r.Height
End With
shp.Select Replace:=False
Set r = Nothing
End If
Next shp
End Sub

Thank you in advance

 

[madvogue29]

For more info this is how I plan to expand the table rows


Private Sub Worksheet_Change(ByVal Target As Range)

Dim x As Long, i As Long
Dim hdr_row As Long, last_row As Long, lastdata_row As Long
Dim tbl As ListObject

'Loop through each sheet and table in the workbook
For Each tbl In ActiveSheet.ListObjects

'Do something to all the tables...


If Not Intersect(Target, tbl.Range) Is Nothing Then
With tbl
'the header row
hdr_row = .HeaderRowRange.Cells(1).Row
'last row of table
last_row = .ListRows.Count + hdr_row
'last row with data in listcolumn(1) <-- first table column
lastdata_row = .DataBodyRange.Cells(.ListRows.Count, 1).End(xlUp).Row
'number of existing blank rows
x = last_row - lastdata_row
'if less than 3 blanks add another 5
If x < 3 Then
Application.EnableEvents = False
For i = 1 To 5
.ListRows.Add
Next i
Application.EnableEvents = True
End If
End With

'pass the range and other data from here to ResizeBox1()

End If

Next tbl
End Sub

 

[NoSparks]

Hello madvogue29,

Please use code tags when posting code
- highlight your code and click the VBA icon at the top for 'Quick-wrap selection as VBA code'
Thanks.

Do your tables and textboxes have similar associated names
ie: textbox1 with table1, textbox2 with table2, etc ?

How many tables are you dealing with on the same sheet ?

Do the textboxes all start and end in the same columns ?
- if so, what columns

 

[madvogue29]

Hi NoSparks,, Thanks for replying again. I will follow the code posting rules in future posts. (I have added the code with VBA wraping underneath if it helps)

To answer your questions.

Do your tables and textboxes have similar associated names
ie: textbox1 with table1, textbox2 with table2, etc ?

I havent yet made the sheet but I can plan and make it textbox 1 to table 1 etc.

How many tables are you dealing with on the same sheet ?

Current estimation is 50 but no more than 100.

Do the textboxes all start and end in the same columns ?

I want them to be in the same columns, for example P:T but it doesnt matter as long as they are after the table and have the same height as corresponding table.

Sub ResizeBox1()
Dim sTL As String
Dim sBR As String
Dim r As Range
Dim shp As Shape

Set r = Range("A120:t182") ' These values would be dynamic later (I plan to get this as an input from another function)

' Change top-left and bottom-right addresses as desired
sTL = "P120" ' These values would be dynamic later
sBR = "d62" ' These values would be dynamic later

' Ensure a text box is selected
For Each shp In ActiveSheet.Shapes
If Not Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), r) Is Nothing Then _

With Selection
Set r = ActiveSheet.Range(sTL)
shp.Top = r.Top
shp.Left = r.Left
Set r = ActiveSheet.Range(sBR)
shp.Width = r.Left + r.Width
shp.Height = r.Top + r.Height
End With
shp.Select Replace:=False
Set r = Nothing
End If
Next shp
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

Dim x As Long, i As Long
Dim hdr_row As Long, last_row As Long, lastdata_row As Long
Dim tbl As ListObject

'Loop through each sheet and table in the workbook
For Each tbl In ActiveSheet.ListObjects

'Do something to all the tables...


If Not Intersect(Target, tbl.Range) Is Nothing Then
With tbl
'the header row
hdr_row = .HeaderRowRange.Cells(1).Row
'last row of table
last_row = .ListRows.Count + hdr_row
'last row with data in listcolumn(1) <-- first table column
lastdata_row = .DataBodyRange.Cells(.ListRows.Count, 1).End(xlUp).Row
'number of existing blank rows
x = last_row - lastdata_row
'if less than 3 blanks add another 5
If x < 3 Then
Application.EnableEvents = False
For i = 1 To 5
.ListRows.Add
Next i
Application.EnableEvents = True
End If
End With

'pass the range and other data from here to ResizeBox1()

End If

Next tbl
End Sub

Again thank you so much for answering my questions and helping me.

 

[NoSparks]

Well, seeing TopLeftCell and BottomRightCell are read only, have changed the method of extending the tables.
Now insert rows so Excel looks after moving the textboxes, then expanding the table, then finding the textbox needing the height adjusted.
The added height may need adjustment depending on your sheet.

Give this a try

Private Sub Worksheet_Change(ByVal Target As Range)

Dim tbl As ListObject, rng As Range, shp As Shape
Dim hdr_Row As Long, last_row As Long, lastdata_row As Long, x As Long

'Loop through each table in the sheet
For Each tbl In ActiveSheet.ListObjects
    'find table where change made
    If Not Intersect(Target, tbl.Range) Is Nothing Then
        'when found, work with it
        With tbl
            'the header row
            hdr_Row = .HeaderRowRange.Cells(1).Row
            'last row of table
            last_row = .ListRows.Count + hdr_Row
            'last row with data in listcolumn(1) <-- first table column
            lastdata_row = .DataBodyRange.Cells(.ListRows.Count, 1).End(xlUp).Row
            'number of existing blank rows
            x = last_row - lastdata_row
            'if less than 3 blanks add another 5
            If x < 3 Then
                Application.EnableEvents = False
                'insert 5 rows below table
                Rows(last_row + 1).Resize(5).Insert
                'resize the table by 5 rows
                Set rng = Range(tbl.Name & "[#All]").Resize(tbl.Range.Rows.Count + 5, tbl.Range.Columns.Count)
                tbl.Resize rng
                Application.EnableEvents = True
                
'               ******************************************************************
                'find the adjacent textbox and resize
                For Each shp In ActiveSheet.Shapes
                    If shp.TopLeftCell.Address = Range("P" & hdr_Row).Address Then
                        shp.Height = shp.Height + 75  '<----- height adjustment
                        Exit For
                    End If
                Next shp
'               ******************************************************************

            End If
            Exit For
        End With
        Exit For
    End If
Next tbl

End Sub

Hope that helps.

 

[madvogue29]

Thanks for the prompt update! the code works but it still has some bugs, sometimes it adds double the height in the text box.

Please have a look at the sheet attached. The sheet name is Prototype 3 and I have added a button that adds new table and textbox.

Spoiler: G DRIVE File Link

Meet Google Drive – One place for all your files

Google Drive is a free way to keep your files backed up and easy to reach from any phone, tablet, or computer. Start with 15GB of Google storage – free.

drive.google.com

 

[NoSparks]

The issue is the position of the bottom of the textboxes.
Some are in the bottom row of the table and some are in the row below the bottom of the table.
The ones ending in the row below the table are automatically resized by Excel when the additional rows are inserted for the table.
The ones ending in the bottom row of the table stay where they are when the rows are inserted.

Two possible solutions are:
1. Extend the bottom of the textboxes so they are just a hair into the row below the table and let Excel automatically look after resizing (no code required), or
2. Change the property of each textbox from Move and size with cells to Move but don't size with cells and use the code for resizing.

 

[madvogue29]

Hi NoSparks,

Thank you for the feedback. I tried both solutions but they both bugged for me.

what worked for me was changing the parameter for the code to the following
shp.Height = shp.Height + 72.5 '<----- height adjustment


changing it to 72.5 comapred to 75 solved the bugs for me in both solutions.

Thanks again for all the help.

 

[NoSparks]

Glad you got it sorted.