VBA To Autosize Shape Based On Length Of Text

[malay]

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 :

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

[Admin]

Hi

this worked for me. (Excel 2010 on Win 8 64 bit)

Selection.Name = "MyShapes"
    Selection.Characters.Text = HelpLkupVal
    Selection.ShapeRange.LockAspectRatio = msoTrue
    Selection.ShapeRange.TextFrame2.AutoSize = msoAutoSizeShapeToFitText