VBA To Autosize Shape Based On Length Of Text
In the selection_change event i add a shape in the sheet and text within the shape, the text length is different in different selection of cells, in this process I have been trying to auto-size (/autofit) the shape by increasing it's height according to the text length so that user can read the whole text, but cannot do so, The code that i used is increasing it's length horizontally and covering the row that has fields underneath :
Code:
Sub Addshape()
Dim ShpLeft As Double
Dim ShpTop As Double
Dim ShpWidth As Double
Dim ShpHeight As Double
Dim HelpLkupRng As Range
Dim HelpLkupVal
Dim Shp As Range
Dim sh As Shape
On Error Resume Next
ActiveSheet.Shapes("MyShapes").Delete
If Left(ActiveCell.Address, 2) = "$E" Then
' ActiveSheet.Shapes("MyShapes").Delete
Set HelpLkupRng = Worksheets("Config").Range("Z1:AA300")
HelpLkupVal = WorksheetFunction.VLookup(ActiveSheet.Range("C" & ActiveCell.Row).value, HelpLkupRng, 2, 0)
If HelpLkupVal = "" Then Exit Sub
Set Shp = Range(Selection.Address)
ShpLeft = 340
ShpTop = Shp.Top - 2
ShpHeight = Shp.Height
ShpWidth = Shp.Width
ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, ShpLeft, ShpTop, 300, 55).Select
Selection.ShapeRange.ShapeStyle = msoShapeStylePreset25
With Selection.ShapeRange.TextFrame2.TextRange.Font
.NameComplexScript = "Arial"
.NameFarEast = "Arial"
.Name = "Arial"
End With
Selection.Name = "MyShapes"
Selection.Characters.Text = HelpLkupVal
'Selection.AutoSize = True
Selection.AutoSize = xlHorizontal
'I tried with "Selection.autosize=true" and "selection.autosize=xlveritcal" , anyway the shape is increasing in length horizontally and not the height
Debug.Print Shp.Left = ShpLeft
Debug.Print Shp.Top = ShpTop
ActiveSheet.Range("E" & ActiveCell.Row).Select
End If
End Sub
Thanks ...
