Exporter/importer des photos

Bonjour,

J'ai des fichiers excel avec plein de photos, qui correspondent à des références.
J'essaye d'exporter les photos, en leurs donnant la valeur qui est dans la colonne précédente.
Etrangement, cela mache dans 90% des cas, mais les 10% d'erreurs me posent problèmes.

Je vous ai fait une petite compile de ce que je fais.
Les références sont dans la colonne A, les photos sont dans la colonne B, elles sont exportées dans le répertoire "c:\photos\export", puis importées dans mon excel en colonne C

Je ne comprends pas ce que je fais de mal

Mon code:

 

Sub Export_Import_images()

   
    Dim Sh As Worksheet
    Dim Path As String, Colonne_Photos As String, Extension As String, Reference As String, Colonne_Ref As String
    Dim ChtObj As ChartObject
    Dim Num_Colonne_Photo As Long, Hauteur_Celulle As Long, Hauteur_Photo As Long, Largeur_Photo As Long, NewLargeur As Long, Largeur_Max As Long, Premiere_Ligne As Long, Ligne As Long, Coeficient As Long
    Dim Shp As Variant, FicImg As Variant
    Dim Sh_Image As Object

' Paramétres
   
    Set Sh = ActiveSheet
    Path = "C:\Photos\Export\"
    Num_Colonne_Photo = 2
    Colonne_Ref = "A"
    Extension = ".JPG"
    Premiere_Ligne = 2
    Colonne_Photos = "C"
    Hauteur_Celulle = 100
    Largeur_Max = 10
   
   

' Export des photos
    
    Application.ScreenUpdating = False
    
    For Each Shp In Sh.Shapes
        On Error Resume Next
        If Not Intersect(Shp.TopLeftCell, Sh.Columns(Num_Colonne_Photo)) Is Nothing Then
            Set ChtObj = Sh.ChartObjects.Add(300, 300, 400, 250)
            ChtObj.Name = "TemporaryPictureChart"
            ChtObj.Width = Sh.Shapes(Shp.Name).Width
            ChtObj.Height = Sh.Shapes(Shp.Name).Height
            ChtObj.Border.LineStyle = 0
            Sh.Shapes.Range(Array(Shp.Name)).Select
            Selection.Copy
            Sh.ChartObjects("TemporaryPictureChart").Activate
            ActiveChart.Paste
            ActiveChart.Export Filename:=Path & Range(Colonne_Ref & Shp.TopLeftCell.Row).Value & ".jpg", FilterName:="jpg"
            ChtObj.Delete
        End If
    Next Shp



' Import des photos

    For Ligne = Premiere_Ligne To Range(Colonne_Ref & Rows.Count).End(xlUp).Row
    Reference = Range(Colonne_Ref & Ligne)
    FicImg = Path & Reference & Extension

    On Error Resume Next

    If FicImg <> "" And Len(Dir(FicImg)) > 0 Then
        Range(Colonne_Photos & Ligne).Select
        Range(Colonne_Photos & Ligne).RowHeight = Hauteur_Celulle
        Set Sh_Image = ActiveSheet.Pictures.Insert(FicImg)
        Hauteur_Photo = Sh_Image.Height
        Largeur_Photo = Sh_Image.Width
        Sh_Image.Delete
        NewLargeur = ((Hauteur_Celulle * Largeur_Photo) / Hauteur_Photo)

        Coeficient = 1

        If NewLargeur > Largeur_Max Then
            Coeficient = 200 / NewLargeur
            Largeur_Max = NewLargeur

        End If

        ActiveSheet.Shapes.AddPicture Filename:=FicImg, linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=ActiveCell.Left + 1, Top:=ActiveCell.Top + 1, Width:=NewLargeur * Coeficient, Height:=(Hauteur_Celulle * Coeficient) - 2
    End If
Next Ligne

Application.ScreenUpdating = True

Range(Colonne_Photos & 1).ColumnWidth = Largeur_Max / 5.2

MsgBox ("C'est fini")


End Sub

Windows / Chrome 112.0.0.0