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

    End If
End Sub

Option Explicit

Sub myAddShape()
    Dim txt  As String
    txt = GetTxt(ActiveCell.Value)
    
    Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
        sh.Delete
    Next
    
    If txt <> "" Then
        Set sh = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 1, 1, 500, 25)
        With sh
            .TextFrame2.TextRange.Characters.Text = txt
            Do
                If .TopLeftCell.Row >= ActiveCell.Row Then Exit Do
                .Top = .Top + 10
            Loop
            Do
                If .TopLeftCell.Column > ActiveCell.Column Then Exit Do
                .Left = .Left + 10
            Loop
        End With
    End If
End Sub

Function GetTxt(ActiveCell_Value As Variant) As String
    With Лист2
        Dim yy As Long
        On Error Resume Next
        yy = WorksheetFunction.Match(ActiveCell_Value, .Columns(1), 0)
        On Error GoTo 0
        If yy > 0 Then
            Dim xx As Long
            xx = .UsedRange.Columns.Count
            If xx = 1 Then xx = 2
            Dim arr As Variant
            Dim brr As Variant
            arr = .Cells(yy, 1).Resize(1, xx)
            ReDim brr(1 To UBound(arr, 2))
            For xx = 1 To UBound(arr, 2)
                brr(xx) = arr(1, xx)
            Next
            GetTxt = Join(brr, "    ")
        End If
    End With
End Function

       With sh
            .TextFrame2.TextRange.Characters.Text = txt
            Do
                If .TopLeftCell.Row >= ActiveCell.Row Then Exit Do
                .Top = .Top + 10
            Loop
            Do
                If .TopLeftCell.Column > ActiveCell.Column Then Exit Do
                .Left = .Left + 10
            Loop
        End With

        With sh
            .TextFrame2.TextRange.Characters.Text = txt
            .Top = ActiveCell.Top + 1
            .Left = ActiveCell.Width + 10
        End With

Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'Sheets(1)
If Not Intersect(Target, Range("a6:a8")) Is Nothing Then
del
With Sheets(2).Columns(1)
Set f = .Find(What:=Target, LookIn:=xlValues, LookAt:=xlWhole)
  If Not f Is Nothing Then
  Target.AddComment Text:="ID: " & f & Chr(10) & "Name: " & .Cells(f.Row, 2) & _
    Chr(10) & "Age: " & .Cells(f.Row, 3) & Chr(10) & _
    "Passport: " & .Cells(f.Row, 3)
  Else
  Target.AddComment Text:="Не найдено."
  End If
End With
Else
  del
End If
End Sub

Sub del()
If ActiveSheet.Comments.Count > 0 Then
  For Each x In ActiveSheet.Comments
  x.Delete
  Next
End If
End Sub