Affichage text box lors d'un clic sur une cellule

'### Constantes à adapter ###
'/// le n° de colonne sur laquelle agit Worksheet_SelectionChange ///
Public Const NUM_COLONNE As Long = 1
'/// le nom de la feuille sur laquelle sont indiquées les infos ///
Private Const FEUILLE_INFOS As String = "infos"
'############################

Public TempoPicture As Shape

Sub ProcInfos(R As Range)
Dim S As Worksheet
Dim R2 As Range
Dim j&
Dim var
Dim bool
'---
If R.Cells.Count > 1 Then Exit Sub
If R = "" Then Exit Sub
'--- Source (copie) ---
Set S = Sheets(FEUILLE_INFOS)
var = S.Range(S.Cells(1, 1), S.Cells(1, S.[a1].End(xlToRight).Column))
For j& = 1 To UBound(var, 2)
  If UCase(R) = UCase(var(1, j&)) Then
    Set R2 = S.Range(S.Cells(2, j&), S.Cells(2, j&))
    Set R2 = S.Range(S.Cells(2, j&), S.Cells(R2.End(xlDown).Row, j&))
    bool = True
    Exit For
  End If
Next j&
If Not bool Then Exit Sub 'aucune correspondance n'a été trouvée, on sort.
'---
R2.CopyPicture
'--- Destination (collage) ---
Set S = R.Parent
Application.EnableEvents = False
R.Offset(0, 1).PasteSpecial
Set TempoPicture = S.Shapes(S.Shapes.Count)
R.Select
Application.EnableEvents = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not TempoPicture Is Nothing Then
  TempoPicture.Delete
  Set TempoPicture = Nothing
End If
If Target.Column = NUM_COLONNE Then
  Call ProcInfos(Target)
End If
End Sub