XL 2019 Condition si image présente

[farid]

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

 

[mapomme]

Bonjour @farid ,

On ne place l'image en J5 que qi la cellule J5 ne comporte pas d'image :

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

 

[farid]

Bonjour @farid ,

On ne place l'image en J5 que qi la cellule J5 ne comporte pas d'image :

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

 

[mapomme]

mais je n'ai pas d'image qui s'affiche !

Voici le fichier.
Chez moi, ça fonctionne. Et chez toi ?

 

[farid]

Voici le fichier.
Chez moi, ça fonctionne. Et chez toi ?

Nickel, merci à toi, mais je vais revenir vers toi sur ce sujet tout à l'heure, merci

 

[farid]

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

 

[patricktoulon]

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

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

 

[farid]

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

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

 

[patricktoulon]

re
corrigé

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

 

[farid]

re
corrigé

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

Merci beaucoup.
Bonne soirée