Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MyCell As Range
Dim MyPicture As Picture
Dim Pict As Shape
Dim Fichier$, CheminFichier$
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
' définit la cellule qui accueil l'image (devant la cellule active !)
Set MyCell = Target.Offset(0, 1): MyCell.Select
' supprime toutes les images nommées "Picture no"
For Each Pict In ActiveSheet.Shapes
If Left(Pict.Name, 7) = "Picture" Then Pict.Delete
Next
' si un nom sélectionné . . .
If Trim(Target.Value) > "" Then
Fichier = Target.Value & ".jpg" 'nom du fichier image dans cette cellule avec l'extention
CheminFichier = ThisWorkbook.Path & "\" & Fichier ' chemin complet avec nom fichier image
Fichier = Dir(CheminFichier)
If Fichier > "" Then
Set MyPicture = ActiveSheet.Pictures.Insert(CheminFichier)
With MyPicture.ShapeRange
.LockAspectRatio = msoFalse
.Top = MyCell.Top: .Left = MyCell.Left
.Height = MyCell.Height: .Width = MyCell.Width
End With
MyCell.Select
End If
End If
'fin sortie
Application.ScreenUpdating = True
On Error GoTo 0: Err.Clear
Exit Sub
ErrorHandler: 'traitement d'erreur
Dim Msg$
Application.ScreenUpdating = True
Msg = "Erreur " & Err.Source & " No " & Err.Number & vbLf & vbLf & Err.Description
MsgBox Msg, vbCritical, "", Err.HelpFile, Err.HelpContext
On Error GoTo 0: Err.Clear
End Sub