XL 2016 Insertion automatique d'une photo dans une cellule

Jean Marc DALPHRASE · 19 Mars 2024

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 · 19 Mars 2024

Bonsoir Jean Marc DALPHRASE, bienvenue sur XLD,

Testez cette macro :

VB:

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 · 20 Mars 2024

Bonjour le forum,

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

VB:

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 · 21 Mars 2024

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

Jean Marc DALPHRASE · 28 Mars 2024

Bonjour

job75 à dit:

Bonjour le forum,

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

VB:

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 · 28 Mars 2024

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

XL 2016 Insertion automatique d'une photo dans une cellule

Jean Marc DALPHRASE

XLDnaute Nouveau

Pièces jointes

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Jean Marc DALPHRASE

XLDnaute Nouveau

Jean Marc DALPHRASE

XLDnaute Nouveau

Jean Marc DALPHRASE

XLDnaute Nouveau

Pièces jointes

Discussions similaires