Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Cells.Count = 1 Then
        If Not Intersect(Target, Range("D5:D21")) Is Nothing Then
            Dim sp As Shape
            For Each sp In ActiveSheet.Shapes
                Select Case sp.Type
                Case 1
                    sp.Delete
                End Select
            Next
            Set sp = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, Target.Left, Target.Top, 270.75, 127.5)
            sp.TextFrame2.TextRange.Characters.Text = CStr(Target.Value)
        End If
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Cells.Count = 1 Then

            Dim sp As Shape            
            For Each sp In ActiveSheet.Shapes
                Select Case sp.Type
                Case 1
                    sp.Delete
                End Select
            Next

        If Not Intersect(Target, Range("D5:D21")) Is Nothing Then
            Set sp = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, Target.Left, Target.Top, 270.75, 127.5)
            sp.TextFrame2.TextRange.Characters.Text = CStr(Target.Value)
        End If
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    'Выводит в форму текст ячейки.
    'Подгоняет размер формы под длину строки.
    If Target.Cells.Count = 1 Then
 
            Dim sp As Shape
            For Each sp In ActiveSheet.Shapes
                Select Case sp.Type
                Case 1
                    sp.Delete
                End Select
            Next
 
        If Not Intersect(Target, Range("D5:D21")) Is Nothing Then
            Dim wihe As Variant
            Dim s As String
            s = CStr(Target.Value)
            If s <> "" Then
                wihe = GetWidthHeight(s)
                 
                Set sp = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, Target.Cells(2, 2).Left, Target.Cells(2, 2).Top, wihe(0), wihe(1))
                With sp.TextFrame2.TextRange
                    With .Font
                        .NameComplexScript = "Courier New"
                        .NameFarEast = "Courier New"
                        .Name = "Courier New"
                        .Size = 10
                    End With
                    .Characters.Text = s
                End With
            End If
        End If
    End If
End Sub

Function GetWidthHeight(ByVal s As String) As Variant
    Dim arr As Variant
    ReDim arr(0 To 1)
    arr(0) = 5
    arr(1) = 10
    Dim maxWi As Long
    If s <> "" Then
        s = Replace(s, vbCrLf, vbCr)
        s = Replace(s, vbLf, vbCr)
        Dim brr As Variant
        brr = Split(s, vbCr)
        Dim l As Long
        Dim i As Long
        Dim st As Variant
        For Each st In brr
            l = Len(st)
            i = Int(l / 100) + 1
            arr(1) = arr(1) + 15 * i
            
            If l > 100 Then
                maxWi = 600
            Else
                If maxWi < 6 * l Then maxWi = 6 * l
            End If
        Next
    End If
    arr(0) = arr(0) + maxWi
    
    GetWidthHeight = arr
End Function