XL 2019 Condition si image présente

  • Initiateur de la discussion Initiateur de la discussion farid
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

farid

XLDnaute Occasionnel
Bonjour,
dans mon fichier en PJ, j'ai un petit bout de macro qui (fonctionne) et modifié.
Cependant, si je clique sur le bouton, cela ajoute sans fin la même image et c'est gênant
J'aurais voulu insérer une condition si image ("PJ"). Visible =true sur la feuille alors, je sors sinon j'applique la ligne de commande pour mettre cette image selon la macro.
Par avance merci
bien cordialement
 

Pièces jointes

Solution
re
corrigé
VB:
Sub Image()
    Nom = Cells(3, "A").Value
    With Feuil1
        For Each shap In .Shapes
            If shap.Name = Nom Then MsgBox "image déjà présente": Exit Sub
        Next

        Sheets("Feuil2").Shapes(Nom).CopyPicture
        .Pictures.Paste
        With .Shapes(.Shapes.Count)
            .Name = Nom
            .Left = [j5].Left: .Top = [j5].Top
        End With
    End With
End Sub
Bonjour @farid 🙂,

On ne place l'image en J5 que qi la cellule J5 ne comporte pas d'image :
VB:
Sub Image()
Dim x, dejaImage As Boolean
   On Error GoTo Fin
   Sheets("Feuil2").Shapes(Sheets("Feuil1").Cells(3, "A").Value).Copy
   Application.Goto Sheets("Feuil1").Range("j5")
   For Each x In Sheets("Feuil1").Shapes
      If x.TopLeftCell.Address(0, 0) = "J5" Then dejaImage = True: Exit For
   Next x
   If Not dejaImage Then Sheets("Feuil1").Paste
Fin:
End Sub
 
Bonjour @farid 🙂,

On ne place l'image en J5 que qi la cellule J5 ne comporte pas d'image :
VB:
Sub Image()
Dim x, dejaImage As Boolean
   On Error GoTo Fin
   Sheets("Feuil2").Shapes(Sheets("Feuil1").Cells(3, "A").Value).Copy
   Application.Goto Sheets("Feuil1").Range("j5")
   For Each x In Sheets("Feuil1").Shapes
      If x.TopLeftCell.Address(0, 0) = "J5" Then dejaImage = True: Exit For
   Next x
   If Not dejaImage Then Sheets("Feuil1").Paste
Fin:
End Sub
Bonjour Mapomme;
merci pour ce retour rapide. Je viens d'essayer ta proposition, mais je n'ai pas d'image qui s'affiche !

merci beaucoup
 

Pièces jointes

Nickel, merci à toi, mais je vais revenir vers toi sur ce sujet tout à l'heure, merci
Le résultat de ta formule concerne une adaptation sur mon fichier source .
Le fichier est beaucoup trop lourd et il y a confidentialité,
j'ai cette macro qui fonctionne très bien à une exception prête, lors du "PasteSpecial", il ne prend pas l'image en compte, est-ce possible d'y intégré le collage avec l'image sans changer les valeurs dans les cellules
Merci à toi



Sub enregistrement2()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
nm = ActiveWorkbook.Name
tb = Split(nm, ".")
If Left(nm, 2) = "23" Then rep1 = ActiveWorkbook.Path Else rep1 = ActiveWorkbook.Path & "\SAUVEGARDE-OT\2023"
rg = tb(0)
Nom = Range("A4").Value & ".xlsm"
rep1 = rep1 & "\" & Nom
A = Left(Nom, 2): ActiveWorkbook.SaveAs rep1
Range("A4:S4").Copy
Workbooks("OT-MAINTENANCE.xlsm").Activate
Set celluletrouvee = Sheets("2023").Range("A3:A1000").Find(rg, lookat:=xlWhole)
If celluletrouvee Is Nothing Then MsgBox "Ligne non trouvée": Exit Sub
ligne = celluletrouvee.Row

Range("A" & ligne).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False


Application.DisplayAlerts = False
Application.ScreenUpdating = True

End Sub
 
bonjour @farid
je te l'ai dis la dernière fois
les select et activate et ttout i cointi tu oublie
et du même coup les screnupdating et compagnie
VB:
Sub Image()
    nom = Cells(3, "A").Value
    For Each shap In Feuil1.Shapes
        If shap.Name = nom Then MsgBox "image déjà présente": Exit Sub
    Next

    Sheets("Feuil2").Shapes(nom).CopyPicture
    With Feuil1
         .Pictures.Paste
        With .Shapes(.Shapes.Count)
            .Name = nom
            .Left = .[j5].Left: .Top = .[j5].Top
        End With
    End With
End Sub
😉
 
bonjour @farid
je te l'ai dis la dernière fois
les select et activate et ttout i cointi tu oublie
et du même coup les screnupdating et compagnie
VB:
Sub Image()
    nom = Cells(3, "A").Value
    For Each shap In Feuil1.Shapes
        If shap.Name = nom Then MsgBox "image déjà présente": Exit Sub
    Next

    Sheets("Feuil2").Shapes(nom).CopyPicture
    With Feuil1
         .Pictures.Paste
        With .Shapes(.Shapes.Count)
            .Name = nom
            .Left = .[j5].Left: .Top = .[j5].Top
        End With
    End With
End Sub
😉
Bonsoir Patrick ,
merci pour ce retour, cependant lorsque je fais le test j'ai un bug et en plus l'image vient ce collet en J15 au lieu de J5!
merci
 

Pièces jointes

re
corrigé
VB:
Sub Image()
    Nom = Cells(3, "A").Value
    With Feuil1
        For Each shap In .Shapes
            If shap.Name = Nom Then MsgBox "image déjà présente": Exit Sub
        Next

        Sheets("Feuil2").Shapes(Nom).CopyPicture
        .Pictures.Paste
        With .Shapes(.Shapes.Count)
            .Name = Nom
            .Left = [j5].Left: .Top = [j5].Top
        End With
    End With
End Sub
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
0
Affichages
1 K
Retour