Bug affichage images excel

sub insert

ThisWorkbook 
Private Sub Workbook_Open()

End Sub

Option Explicit
Sub insertion_img()
Dim i As Integer
Dim chemin As String
Dim rep As String
Dim nom As String
Dim Nlignes As Long
Dim img
Nlignes = Application.CountA(Range("B:B"))

Range("Y3").Select
rep = ThisWorkbook.Path & "\Base_vignettes\"
Application.ScreenUpdating = False
For i = 1 To (Nlignes - 2)
nom = Split(ActiveCell.Value, "/")(5)
chemin = rep & nom
If WorksheetFunction.IsNA(ActiveCell.Address) Then
            ActiveCell.Offset(0, 1).Value = "pas d'image"
            ActiveCell.Offset(1, -1).Select
    Else
ActiveCell.Offset(0, 1).Select
ActiveCell.RowHeight = 100
Set img = ActiveSheet.Pictures.Insert(chemin)
With img
    img.Top = ActiveCell.Top
    img.Left = ActiveCell.Left
    img.Name = Left(chemin, Len(chemin) - 4) & i ' Donne un nom à l'image
    img.Height = 100 ' s'ajuste à la hauteur de la ligne
    img.Placement = xlMoveAndSize
    ActiveCell.Offset(1, -1).Select
End With
End If
Next
MsgBox ("fin de traitement")
Application.ScreenUpdating = True
End Sub