Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim Val As String
Dim MyCell As Range
Dim MyPicture As Picture
Dim Pict
Dim fs, Dossier, Fichier, Fichiers
On Error GoTo errorhandler
Application.ScreenUpdating = False
[COLOR=Red]Val = Target.Value[/COLOR]
Set fs = CreateObject("Scripting.FileSystemObject")
Set Dossier = fs.GetFolder(ThisWorkbook.Path)
Set Fichiers = Dossier.Files
For Each Fichier In Fichiers
If LCase(Right(Fichier.Name, 3)) = "jpg" Then
Set MyCell = Target.Offset(0, 1)
MyCell.Select
For Each Pict In ActiveSheet.DrawingObjects ' supprimer ancienne image dans cellule
If Pict.Left = MyCell.Left And Pict.Top = MyCell.Top Then Pict.Delete
Next
Set MyPicture = ActiveSheet.Pictures.Insert([COLOR=Red]ThisWorkbook.Path & "\" & Val & ".jpg"[/COLOR])
With MyPicture.ShapeRange
.LockAspectRatio = msoFalse
.Height = MyCell.Height
.Width = MyCell.Width
End With
MyCell.Select
End If
Next
errorhandler:
Application.ScreenUpdating = True
End Sub