With ActiveSheet.Shapes.Range(Array("TextBox 1"))

With ActiveSheet.Shapes.Range(Array("TextBox 1"))

Private Sub Workbook_Open()
Dim rr As Range, rc As Range
On Error Resume Next
Application.ScreenUpdating = False
'в строке ниже замените адреса ячеек на нужные Вам
Set rr = Worksheets("Лист1").Range("A1,C1,G5,C7:C14,E7:E8,G7:G9")
If rr Is Nothing Then Exit Sub
On Error GoTo 0
For Each rc In rr.Cells
    With rc
        If Len(.Value) Then
            .Hyperlinks.Add rc, "", "", (.Value), (.Value)
            With .Font
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Underline = xlUnderlineStyleNone
            End With
        End If
    End With
Next
Application.ScreenUpdating = True
End Sub

Option Explicit

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("A1:A10")) Is Nothing Then
            Dim wihe As Variant
            Dim s As String
            s = CStr(Target.Cells(1, 2).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

If Not Intersect(Target, Range("A1:A10, C1:C10")) Is Nothing Then
    If Target.Column = 1 Then