XL 2016 Insertion automatique d'une photo dans une cellule

Jean Marc DALPHRASE

XLDnaute Nouveau
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é.
 

Pièces jointes

  • Prépa_PROMOS1.xlsx
    40.9 KB · Affichages: 18

job75

XLDnaute Barbatruc
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+
 
Dernière édition:

job75

XLDnaute Barbatruc
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+
 
Dernière édition:

Jean Marc DALPHRASE

XLDnaute Nouveau
Bonjour
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+
 

Discussions similaires

Statistiques des forums

Discussions
313 198
Messages
2 096 132
Membres
106 504
dernier inscrit
Kannankin Maxime