XL 2016 Insertion automatique d'une photo dans une cellule

[Jean Marc DALPHRASE]

Bonjour.
Je galère pour trouver le moyen d'insérer automatiquement une photo à partir d'une cellule adjacente contenant le chemin de celle ci. La formule "insère" va pour quelques lignes, mais mon tableau peu en comporter plus de 100.
Pouvez vous m'aider S.V.P.
Ci joint une partie du tableau concerné.

 

[job75]

Bonsoir Jean Marc DALPHRASE, bienvenue sur XLD,

Testez cette macro :

Sub Insertion_Images()
Dim c As Range
Application.ScreenUpdating = False
ActiveSheet.DrawingObjects.Delete
For Each c In Range("G2", Range("G" & Rows.Count).End(xlUp))
    If Dir(CStr(c)) <> "" Then
        With ActiveSheet.Pictures.Insert(c.Value).ShapeRange
            .LockAspectRatio = True 'pour conserver les proportions de l'image
            .Top = c(1, 0).Top
            .Left = c(1, 0).Left
            If .Height / .Width > c(1, 0).Height / c(1, 0).Width Then
                .Height = c(1, 0).Height
            Else
                .Width = c(1, 0).Width
            End If
        End With
    End If
Next
End Sub

Chez moi la création de 100 images se fait en 3 secondes.

Edit : ajouté CStr pour le cas où une cellule est vide.

A+

 

[job75]

Bonjour le forum,

Avec cette macro l'image est centrée dans la cellule :

Sub Insertion_Images()
Dim c As Range
Application.ScreenUpdating = False
ActiveSheet.DrawingObjects.Delete
For Each c In Range("G2", Range("G" & Rows.Count).End(xlUp))
    If Dir(CStr(c)) <> "" Then
        With ActiveSheet.Pictures.Insert(c.Value).ShapeRange
            .LockAspectRatio = True 'pour conserver les proportions de l'image
            If .Height / .Width > c(1, 0).Height / c(1, 0).Width Then
                .Height = c(1, 0).Height
                .Top = c(1, 0).Top
                .Left = c(1, 0).Left + (c(1, 0).Width - .Width) / 2
            Else
                .Width = c(1, 0).Width
                .Left = c(1, 0).Left
                .Top = c(1, 0).Top + (c(1, 0).Height - .Height) / 2
            End If
        End With
    End If
Next
End Sub

A+

 

[Jean Marc DALPHRASE]

Chapeau job75, Ca fonctionne parfaitement.
Un grand merci avec le bonjour de Cayenne en Guyane.
JMD.

 

[Jean Marc DALPHRASE]

Bonjour

Bonjour le forum,

Avec cette macro l'image est centrée dans la cellule :

Sub Insertion_Images()
Dim c As Range
Application.ScreenUpdating = False
ActiveSheet.DrawingObjects.Delete
For Each c In Range("G2", Range("G" & Rows.Count).End(xlUp))
    If Dir(CStr(c)) <> "" Then
        With ActiveSheet.Pictures.Insert(c.Value).ShapeRange
            .LockAspectRatio = True 'pour conserver les proportions de l'image
            If .Height / .Width > c(1, 0).Height / c(1, 0).Width Then
                .Height = c(1, 0).Height
                .Top = c(1, 0).Top
                .Left = c(1, 0).Left + (c(1, 0).Width - .Width) / 2
            Else
                .Width = c(1, 0).Width
                .Left = c(1, 0).Left
                .Top = c(1, 0).Top + (c(1, 0).Height - .Height) / 2
            End If
        End With
    End If
Next
End Sub

A+

 

[Jean Marc DALPHRASE]

Bonjour.
Cette macro peut elle être transformé en complément dans Excel comme le générateur de code barre EAN13