XL 2019 Insérer une image en fonction de valeur cellule mais sur plusieurs lignes

[schum23]

Bonjour,

J'ai fouillé pas mal sur votre Forum mais je n'ai pas trouvé mon bonheur.
Je suis entrain de travailler sur un template qui automatiserait les offres de nos commerciaux.
Du coup, dans ma feuille "OFFER_TEMPLATE", dans la colonne A, en fonction du groupe que nous choisissons, nous avons accès un certains nombre d'Item.
Ensuite, des vlookup font le travail pour afficher le nom de l'article, la descritpion, le choix de la langue,...

J'ai une feuille "DATABASE" ou se trouve toutes les informations quant aux produits.

Ce que j'aimerai faire, c'est une sorte de vlookup mais avec des images.
En effet, dans ma feuille "DATABASE", pour chaque SKU il y aura une image.
J'aimerai que dans ma feuille "OFFER_TEMPLATE", quand je sélectionne un item, l'image correspondante s'affiche dans :
- C8 pour B8
- C9 pour B9
- C10 pour B10
-...

J'ai réussi à le faire pour ma première ligne (avec l'appareil photo, et ensuite l'image qui fait référence à une liste, cette même liste est définie par la formule vlookup et indirect).
Cependanjt, si je tire la case C8 vers le bas, ce sera toujours en fonction de la valeur dans la case B8. Si je retire les $ dans la formule pour ma Listes_Pictures, cela fait un problème REF.

Est-ce que quelqu'un pourrait m'aider? Via ce moyen ou VBA, ou autre..?


Un tout grand merci.

 

[danielco]

Bonjour,

Supprime les images de la colonne C de la feuille OFFER_TEMPLATE et mets ce code dans le module de la feuille OFFER_TEMPLATE :

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim C As Range, Sh As Shape, Plage As Range
  If Target.Column <> 2 Then Exit Sub
  With Sheets("DATABASE")
    Set Plage = .Range("B2", .Cells(.Rows.Count, 2).End(xlUp))
  End With
  With Sheets("OFFER_TEMPLATE")
    If Target.Value = "" Then
      For Each Sh In .Shapes
        If Sh.TopLeftCell.Address = Target.Address Then
          Sh.Delete
        End If
      Next Sh
    Else
'      On Error Resume Next
      For Each C In Plage
        If C = Target Then
          For Each Sh In Sheets("DATABASE").Shapes
            If Sh.TopLeftCell.Address = C.Offset(, 2).Address Then
              Sh.Copy
              Exit For
            End If
          Next Sh
          Exit For
        End If
      Next C
      Target.Offset(, 1).PasteSpecial
'      On Error GoTo 0
    End If
  End With
End Sub

Enregistre le classeur au format .xlsm.

Cordialement.

Daniel

 

[job75]

Bonjour schum23, danielco,

Si Target est constituée de plusieurs cellules la macro précédente beugue.

Effacez par exemple la plage B8:B9.

Il faut étudier séparément chaque cellule de Target.

Par ailleurs il faut éviter d'empiler les Shapes les unes sur les autres dans une même cellule...

A+

 

[danielco]

Bonjour job75,

Pour prendre en compte tes remarques, voici la macro modifiée :

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim C As Range, Sh As Shape, Plage As Range
  If Target.Column <> 2 Then Exit Sub
  If Target.Count > 1 Then Exit Sub
  With Sheets("DATABASE")
    Set Plage = .Range("B2", .Cells(.Rows.Count, 2).End(xlUp))
  End With
  With Sheets("OFFER_TEMPLATE")
    For Each Sh In .Shapes
      If Sh.Type <> msoFormControl Then
        If Sh.TopLeftCell.Address = Target.Offset(, 1).Address Then
          Sh.Delete
        End If
      End If
    Next Sh
    If Target.Value <> "" Then
      For Each C In Plage
        If C = Target Then
          For Each Sh In Sheets("DATABASE").Shapes
            If Sh.TopLeftCell.Address = C.Offset(, 2).Address Then
              Sh.Copy
              Exit For
            End If
          Next Sh
          Exit For
        End If
      Next C
      Target.Offset(, 1).PasteSpecial
    End If
  End With
End Sub

Elle ne prend pas en compte des modifications multiples de la colonne B. Dans ce cas, elle ne fait rien, bien qu'on puiss facilement la modifier, au besoin.

Daniel

 

[job75]

Bonjour schum23, danielco, le forum,

Voyez le fichier joint et cette macro :

Private Sub Worksheet_Change(ByVal Target As Range)
Set Target = Intersect(Target, Range("B7:B" & Rows.Count), UsedRange)
If Target Is Nothing Then Exit Sub
Dim i As Variant, a$, o As Object
Application.ScreenUpdating = True
Application.CopyObjectsWithCells = True 'si ce n'est pas le cas
With Sheets("DATABASE")
    Columns(3).ColumnWidth = .Columns(4).ColumnWidth 'même largeur
    For Each Target In Target 'si entrées/effacements multiples
        a = Target(1, 2).Address
        For Each o In DrawingObjects
            If o.TopLeftCell.Address = a Then o.Delete
        Next o
        i = Application.Match(Target, .Columns(2), 0)
        If IsNumeric(i) Then
            Target.RowHeight = .Rows(i).RowHeight 'même hauteur
            .Cells(i, 4).Copy Target(1, 2) 'copie la cellule et l'objet
            Target(1, 2).Borders.LineStyle = xlNone 'supprime les bordures
        End If
    Next Target
End With
End Sub

Il serait bien de revoir les formules en colonnes F H I...

Bonne journée.

 

[schum23]

Bonjour messieurs,

Tout d'abord je tiens à vous remercier tous pour votre contributions à mon fichier. Je suis vraiment super content de la réactivité que j'ai pu trouver sur ce forum, je n'en reviens pas!!!
Je viens d'utiliser le dernier fichier envoyé par job75, et y ait ajouter mes denières modifications, et tout fonctionne parfaitement!!! Je suis super ravi!! Encore mille merci.

Effectivement, les formules dans les F H I sont bonnes, c'est juste que je devais rajouter mes prix qui sont issus d'un autre fichier.

Encore merci tout le monde!!

Bonne journée.

 

[danielco]

@job75 :
J'ai appris "CopyObjectsWithCells", merci. Par contre, je ne comprends pas pourquoi tu ajoutes "UsedRange" dans :

Set Target = Intersect(Target, Range("B7:B" & Rows.Count), UsedRange)

Daniel

 

[job75]

Par contre, je ne comprends pas pourquoi tu ajoutes "UsedRange" dans :

Set Target = Intersect(Target, Range("B7:B" & Rows.Count), UsedRange)

C'est classique : UsedRange permet de limiter la plage à étudier, par exemple si l'on copie la colonne B entière sur elle-même.

 

[danielco]

Compris, merci.

Daniel

 

[schum23]

Bonjour tout le monde,

Je reviens vers vous car j'ai encore besoin de vous concernant du VBA.
Je vous explique :

J'aimerai créer un bouton type userform "PRINT TO PDF" qui serait présent sur la page "LAST PAGE" de mon fichier excel. J'aimerai que quand on clique sur celui ci, il y ait une action type Print to PDF ou Save to Pdf et j'aimerai que les pages suivantes soit imprimées :

- 1st Page
- CMD_SOLUTIONS --> mais imprimer que jusqu'à la dernière ligne complétée et que si le tableau est complété
- Hardware_Software --> Que si il y a un élément dans le tableau en dessous
- LAST page

Ca serait top si tout était dans un fichier PDF.

Pensez-vous que c'est possible?
Je vous joins le fichier en annexe.

Je vous remercie d'ores et déjà pour votre aide.

 

[schum23]

Voici le fichier

 

[job75]

Bonsoir,

Charte du forum :

3 – Le titre de la question doit être clair et comporter explicitement le sujet de la demande. Cela sous-entend qu’une nouvelle demande fait l’objet d’un nouveau fil.

A+