Problème d'inser image

Bonjour à tous,

j'essaye depuis des semaines à faire correspondre une case d'une feuille excel à une image contenu dans un fichier. Je m'explique:

Article (a1) Miniature(b1)

Accroche Poids Crantée(a2) case vide (b2)
Accroche Poids Ronde (a3) etc....
Adoucisseur d'eau CTA

le fichier où se situe mes photos, s'intitule D:\Inventaire\Photos

DOnc j'aimerais grâce a une macro, afficher l'image (par exemple) de l'accroche poids crantée en case b2 ,

voici ma macro actuelle qui ne fonctionne pas :

Sub InserImage()

Dim i As Integer, j As Integer, path As String, sep As String, img As String
Dim objImg As Object
Dim Emplacement As Range

path = "D:\Inventaire\Photos\*"

For i = 1 To 1000

While Range("B2").Offset(i, 0) <> ""
j = j + 1
i = j
Wend

'If Dir(img) = "" Then Exit Sub"

ActiveSheet.Pictures.Insert(path & Range("A2").Offset(i, 0).Value & ".jpg").Select

Set Emplacement = Range("B2").Offset(i, 0)
Range("B2").Offset(i, 0).Value = "."
Set objImg = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count)

With objImg.ShapeRange
.LockAspectRatio = msoFalse
.Left = Emplacement.Left + 2
.Top = Emplacement.Top + 2
.Height = Emplacement.Height - 3.5
.Width = Emplacement.Width - 3.5

End With

Next

End Sub

Merci d'avance de vos réponses