Afficher une image sur plusieurs cellules

Bonjour,

J’ai récupéré une macro qui permet d’afficher une image sur une cellule

Serait-il possible de faire apparaitre l’image sur un nombre de cellules

Pour mon cas récupérer le nom du fichier en AP102 et l’image, apparaitrait en AH102:AH109

Je vous remercie de vos réponses comme de votre aide.

Option Explicit

Sub Affiche_Image()

Dim Ws As Worksheet ' Sert à manipuler plus facilement l'objet feuille

Dim Image As String ' Contiendra le nom de l'image

Dim Lg As Long ' Numéro de la dernière ligne colonne D

Set Ws = Sheets("control") ' Nom de la feuille

Application.ScreenUpdating = False ' Interdit le raffraîchissement d'écran

Efface_Images

With Ws

For Lg = 102 To .Range("AP65536").End(xlUp).Row ' Parcourt de toute la colonne D

Image = ThisWorkbook.Path & "\logo\" & .Cells(Lg, "AP") ' Répertoire à actualiser

On Error Resume Next ' On s'affranchit des erreurs

With .Pictures.Insert(Image).ShapeRange ' On insère l'image dont le nom est en colonne C

.LockAspectRatio = msoFalse ' On peut la redimmensionner comme on veut

.Left = Ws.Cells(Lg, "AH").Left ' Position gauche

.Top = Ws.Cells(Lg, "AH").Top ' Position Haut

.Width = Ws.Cells(Lg, "AH").Width ' Largeur

.Height = Ws.Cells(Lg, "AH").Height ' hauteur

End With

If Err.Number > 0 Then ' Si une erreur (image non présente)

MsgBox .Cells(Lg, "AP") & vbCr & "Image inexistante" ' On le signale

End If

Next Lg

End With

End Sub

Sub Efface_Images()

Dim Ws As Worksheet ' Sert à manipuler plus facilement l'objet feuille

Dim sh As Shape ' Sert à manipuler les formes (images) déjà affichées

Set Ws = Sheets("control") ' Nom de la feuille

With Ws

For Each sh In .Shapes ' Parcourt de toute la collection formes (images)

If Not Intersect(.Columns(34), sh.TopLeftCell) Is Nothing Then ' si elle est dans la colonne 34

sh.Delete ' On l'efface

End If

Next sh

End With

End Sub

Bonjour,

Teste ce qui suit :

Sub Affiche_Image()

    Dim Ws As Worksheet ' Sert à manipuler plus facilement l'objet feuille
    Dim Image As String ' Contiendra le nom de l'image
    Dim Lg As Long ' Numéro de la dernière ligne colonne D

    Set Ws = Sheets("control") ' Nom de la feuille

    Application.ScreenUpdating = False ' Interdit le raffraîchissement d'écran

    Efface_Images

    With Ws

        For Lg = 102 To .Range("AP65536").End(xlUp).Row ' Parcourt de toute la colonne D

        Image = ThisWorkbook.Path & "\logo\" & .Cells(Lg, "AP") ' Répertoire à actualiser

        On Error Resume Next ' On s'affranchit des erreurs

        With .Pictures.Insert(Image).ShapeRange ' On insère l'image dont le nom est en colonne C

            .LockAspectRatio = msoFalse ' On peut la redimmensionner comme on veut

            .Left = Ws.Range("AH" & Lg).Left ' Position gauche
            .Top = Ws.Range("AH" & Lg).Top ' Position Haut

            .Width = Ws.Range("AH" & Lg).Width  ' Largeur
            .Height = Ws.Range("AH" & Lg + 6).Top + Ws.Range("AH" & Lg + 6).Height ' hauteur

        End With

        If Err.Number > 0 Then ' Si une erreur (image non présente)

            MsgBox .Cells(Lg, "AP") & vbCr & "Image inexistante" ' On le signale

        End If

        Next Lg

    End With

    Application.ScreenUpdating = True 'raffraîchi

End Sub

Hervé.

Génial

Après quelques modifications du code, ça fonctionne

Merci de pour ton aide.

c'est genial