Copier/coller une image suite a un Vlookup

Bonjour,

J'ai fait les recherches sur le site mais malgré cela je n'ai pas réussi à résoudre mon problème.

J'ai besoins de gérer une base de données qui me sert à alimenter un modèle de fiche technique.

Depuis peu je dois ajouter des images à ces fiches techniques, j'ai donc voulu automatiser la chose avec VBA.

J'ai donc deux documents différents :

- Ma base de données, composée de deux onglets

* L'onglet principal

* L'onglet comportant mes images- Mon modèle vide de fiche technique

L'onglet principale, fait référence à un code => ce code sert à faire mon Vlookup dans mon deuxième onglet pour aller trouver la cellule avec l'image => l'image doit aller se placer dans mon modèle de fiche technique.

Mais malheureusement ce n'est pas l'image qui se copie dans mon model mais la valeur à l’intérieur de la cellule trouvé par le Vlookup.

Début du code ...

Sub Transfer()

'Variables
Dim Ligne As Integer
Dim Base As Workbook, Modele As Workbook, Nouvelle As Workbook
Dim Nom As String, Rep As String
Dim UVC As Shape
Dim Codepal As Long

'Suppression temporaire des alertes et de la mise a jour écran
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Définition de ce que contienne les variables
Ligne = 6

'On identifie le fichier actif comme la base de donnée
Set Base = ThisWorkbook

Do

    Base.Sheets("Fiches_techniques").Activate

'Dans le dossier actif, on recherche les lignes marquées d'un "X" dans la colonne A et qui sera donc à mettre à jours
If Range("A" & Ligne) = ("X") Then 'si il y a un "X" dans "Excel" alors...
    'MsgBox "Ligne" & " " & Ligne & " " & "avec X"

    'Ouvrir le model qui est dans le fichier TEMPLATE placé dans le même répertoire que ce fichier
    ChDir (ThisWorkbook.Path)
    Set Modele = Workbooks.Open(Filename:=CurDir(ThisWorkbook.Path) & "\Template\Modele FT.xltm")

    'Copie des données vers la première feuille de la fiche technique
    Modele.Sheets("Complete").Range("A5") = Base.Sheets("Fiches_techniques").Range("C" & Ligne)

... C'est cette partie-là du code qui me pose problème, je vous ai laissé mon meilleur résultat, même si il ne me copie que la valeur et pas l'image ...

 'Rechercher et copier l'image de la palettisation par rapport au code emballage, A la base j'avais fait un "Dim UVC As Shape" mais je n'ai pas réussi à le faire fonctionner ...
        Codepal = Base.Sheets("Fiches_techniques").Range("CS" & Ligne)

        Modele.Sheets("Complete").Range("A44") = WorksheetFunction.VLookup(Codepal, Base.Sheets("Base_palettisation").Range("E4:H150"), 2, False)

Et reprise de la suite du code qui fonctionne très bien ...

'Copie des donnée vers la deuxième feuille de la fiche technique
    Modele.Sheets("Specifications").Range("B4") = Base.Sheets("Fiches_techniques").Range("D" & Ligne)

        'Le nom du fichier sera le même que celui placé en cellule "FD"
    Nom = Base.Sheets("Fiches_techniques").Range("FD" & Ligne)

    'Enregistrer le fichier en Excel
    Sheets("Specifications").Select
    Rep = Range("B4")
    ChDir (ThisWorkbook.Path)
    ActiveWorkbook.SaveAs Filename:= _
    CurDir(ThisWorkbook.Path) & "\Fiches techniques converting\" & Rep & "\" & Nom & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    Set Nouvelle = ActiveWorkbook
    Base.Sheets("Fiches_techniques").Activate

    'Si une croix en PDF alors la copie se fera aussi en PDF dans le bon dossier. Si pas de croix dans Excel alors la croix dans PDF ne servira à rien.
    If Range("B" & Ligne) = ("X") Then
        Rep = Range("D" & Ligne)
        Nouvelle.Activate

    'Enregistrement dans le fichier cible en PDF
        ChDir (ThisWorkbook.Path)
        ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        CurDir(ThisWorkbook.Path) & "\Fiches techniques converting\" & Rep & "\" & Nom & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=False

    Else

    End If

    'puis on passe à la ligne suivante
    Ligne = Ligne + 1

ElseIf Range("A" & Ligne) = ("") Then
    'MsgBox "Autre que X"
    Ligne = Ligne + 1 'Si la colonne A est vide alors on passe directe à la ligne suivante

Else 'Je me laisse la possibilité de mettre autre chose dans la ligne mais que cela n'interfère pas sur ma macro
    'MsgBox "Ligne" & " " & Ligne & " à une autre entrée"
    Ligne = Ligne + 1

End If

'Pour l'instant j'arrête de faire la vérification des croix à la ligne 10
Loop While Ligne <= 10

'Reactivation des alertes et de la mise a jour écran
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "Fin"

End Sub

J'ai chargé une copie simplifiée de mon dossier si cela peut vous aider ?!

Bon courage et merci d'avance pour votre aide !!

Firo

Up

Bonjour,

Mon problème n'est pas clair ? Vous ne comprenez pas ce que je veux dire ? Je prends le problème à l'envers ?

Je veux bien faire un effort mais s'il vous plaît dites-moi ce qu'il vous faut pour pouvoir m'aider.

Merci d'avance,

Firo

- Hey Firo, Pointu ton problème, mais tu ne peux pas gérer des images comme des chiffres. Les formules qui fonctionnent pour des chiffrent ne fonctionnent pas pour des images ! Le Vlookup ne peut pas te servir pour ton problème !

- Ha bon Firo? Mais alors comment dois-je faire ?

- Et bien Firo, traite tes images comme un objet, d'abord donne leur un nom, tu appelleras tes objets grâce à ce nom quand tu en auras besoins !

- Mais ça va être compliqué de leur donner toutes un nom, j'en ai beaucoup des images !

- Mais non Firo, car VBA est ton ami, il va t'aider! Il est facile de renommer toutes tes images rapidement avec cet outil si puissant !

- Ha ouf !!

- Alors, colle ça dans ton code, au départ : cela va renommer tes images ....

Dim UVC As Shape
Dim Codepal As Long

Base.Sheets("Base_palettisation").Activate
For Each UVC In ActiveSheet.Shapes
If Not Intersect(UVC.TopLeftCell, Range("$F$4:$F$500")) Is Nothing Then
UVC.Name = "UVC" & UVC.TopLeftCell.Offset(0, -1)
End If
Next UVC

Et plus loin lorsque en viendra le moment de copier/coller ton image colle ceci ...

Codepal = Base.Sheets("Fiches_techniques").Range("CS" & Ligne)
       Base.Sheets("Base_palettisation").Shapes("UVC" & Codepal).Copy
       Modele.Sheets("Complete").Range("A44").PasteSpecial

Et tu verras que la vie deviendra beaucoup plus rose !!

- Ho merci Firo !! Grâce à toi je n'aurais pas à perdre les une semaine que je planche sur le sujet, vraiment un forum c'est idéal pour t'aider à résoudre et surtout comprendre tes erreurs !!

- De rien mon petit ça me fait plaisir! Le résultat global peux sans doute être simplifié, tu trouveras sans doute une autre âme charitable du forum qui va t'aider à cela (ou pas!) !

... et pour ceux qui auront été intéressé par la réponse de ce problème : De rien, c'est cadeau !!