Aide pour dérouler des cellules avec image dynamiques

Private Sub Worksheet_Change(ByVal target As Range)
Dim P As Range, i As Variant, sel As Range
Set P = Sheets("Stock").[A4].CurrentRegion 'à adapter éventuellement
Application.EnableEvents = False 'désactive les évènements
Application.CopyObjectsWithCells = True 'au cas où, pour copier les objets
[C3,E3,D5] = "" 'RAZ
DrawingObjects.Delete 'supprime les objets
i = Application.Match([A2], P.Columns(1), 0)
If IsNumeric(i) Then
    [C3] = P(i, 2)
    [E3] = P(i, 3)
    [D5] = P(i, 6)
    P(i, 4).Copy
    Set sel = Selection 'mémorise
    [B5].Select
    Paste 'pour coller l'image
    Application.CutCopyMode = 0
    sel.Select
    [B5].Borders.LineStyle = xlNone
    [B5].Borders(xlEdgeLeft).Weight = xlThin
End If
Application.EnableEvents = True 'réactive les évènements
End Sub

Private Sub Worksheet_Activate()
Dim pas As Byte, P As Range, i&, n&
Application.ScreenUpdating = False
Application.CopyObjectsWithCells = True 'au cas où, pour copier les objets
pas = 5 'adapter éventuellement
Set P = Sheets("Stock").[A4].CurrentRegion 'adapter éventuellement
DrawingObjects.Delete 'supprime les objets
[B2:G6] = "": Rows("7:" & Rows.Count).Delete 'RAZ
For i = 1 To P.Rows.Count - 2
    Rows("2:6").Copy Rows("2:6").Offset(i * pas) 'copie les formats
Next
For i = 2 To P.Rows.Count
    Cells(3 + n, 3) = P(i, 2)
    Cells(3 + n, 5) = P(i, 3)
    Cells(5 + n, 4) = P(i, 6)
    P(i, 4).Copy
    Cells(5 + n, 2).Select
    Paste 'pour coller l'image
    Cells(5 + n, 2).Borders.LineStyle = xlNone
    Cells(5 + n, 2).Borders(xlEdgeLeft).Weight = xlThin
    n = n + pas
Next
Columns("B:G").AutoFit 'ajustement largeur
Application.CutCopyMode = 0
Application.Goto [A1], True 'cadrage
End Sub

Sub Imprimer()
Dim nlig&, P As Range
nlig = 30 'multiple du pas 5, adapter éventuellement
With Me.PageSetup
    .Zoom = False
    .FitToPagesWide = 1
    .FitToPagesTall = 1
    Set P = [B2:G6].Resize(nlig)
    While Application.CountA(P)
        .PrintArea = P.Address
        Me.PrintPreview 'pour tester
        'Me.PrintOut 'pour imprimer
        Set P = P.Offset(nlig)
    Wend
End With
End Sub