Dupliquer ligne VBA sur une meme feuille

Bonjour je voudrais les memes ligne de code sur la meme feuille mais pour des cellule différentes.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim design As String
Dim c As Range

 design = ThisWorkbook.Path & "/logos/" & [ac10].Value & ".png"

With ActiveSheet
 If Intersect(Target, .Range("ac10")) Is Nothing Then: Exit Sub

    On Error Resume Next
   .Shapes("nouvelle version").Delete

 Set c = .Range("c10").MergeArea
   .Pictures.Insert(design).Name = "nouvelle version"
   .Shapes(Name).Left = c.Left
   .Shapes(Name).Top = c.Top
   .Shapes(Name).LockAspectRatio = msoTrue
   .Shapes(Name).Height = 100
   .Shapes(Name).Width = 100
   .Range("C2").Select
End With

End Sub

je voudrais rajouter une ligne en remplaçant AC10 par AD10 et C10 par U10

comment faire pour avoir donc ces 2 codes sur la meme feuille. Merci

Salut,

Sans avoir ton fichier à disposition afin de comprendre un peu mieux ton travail et afin de pouvoir faire des essais, je te propose ce code à l'aveugle.

Si ce n'est pas ça, envoie-moi déjà ton fichier.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim design As String
Dim c As Range

design = ThisWorkbook.Path & "/logos/" & [ac10].Value & ".png"

With ActiveSheet

    If Not Intersect(Target, .Range("ac10")) Is Nothing Then
        On Error Resume Next
        .Shapes("nouvelle version").Delete
        Set c = .Range("c10").MergeArea
        .Pictures.Insert(design).Name = "nouvelle version"
        .Shapes(Name).Left = c.Left
        .Shapes(Name).Top = c.Top
        .Shapes(Name).LockAspectRatio = msoTrue
        .Shapes(Name).Height = 100
        .Shapes(Name).Width = 100
        .Range("C2").Select
    End If

    If Not Intersect(Target, .Range("AD10")) Is Nothing Then
        On Error Resume Next
        .Shapes("nouvelle version").Delete
        Set c = .Range("U10").MergeArea
        .Pictures.Insert(design).Name = "nouvelle version"
        .Shapes(Name).Left = c.Left
        .Shapes(Name).Top = c.Top
        .Shapes(Name).LockAspectRatio = msoTrue
        .Shapes(Name).Height = 100
        .Shapes(Name).Width = 100
        .Range("C2").Select
    End If

End With

End Sub

Cordialement.

Merci alors sa fonctionne, mais sa efface l'image de C10 quand je rentre les donnés pour U10.

Je voudrais les deux images en meme temps

Edit : par contre le problem quand je change le titre AD10 sa me bascule limage de C10 en U10

Et je voudrais des images différentes

Yvouille a écrit :

Si ce n'est pas ça, envoie-moi déjà ton fichier.

Mon fichier est trop gros. plus de 1mo.. je ne peux pas l'envoyer ici

Un fichier trop gros peut se réduire. Tu en fais une copie, tu supprimes les feuilles inutiles, sur les feuilles qui restent, tu supprimes 9990 lignes sur les 10'000 qu'elles comportent et tu en laisses 10 représentatives, etc.

Voila j'ai refait un classeur plus léger.

J'aimerai deux image différente, dans deux cellule différente. Merci

Ton code supprime une image en place sur la base du nom qui lui a été donné ("nouvelle version") puis va chercher une nouvelle image dans un autre fichier, la colle ici et la renomme avec le même nom pour pouvoir la supprimer au prochain lancement du code.

Je te propose alors de tenter de nommer différemment la deuxième image afin de pouvoir la traiter séparément. Voici une proposition pour la deuxième partie de ce code :

    .........
If Not Intersect(Target, .Range("g4")) Is Nothing Then
        On Error Resume Next
        .Shapes("NOUVELLE VERSION BIS").Delete
        Set c = .Range("g4").MergeArea
        .Pictures.Insert(design).Name = "NOUVELLE VERSION BIS"
        .Shapes(Name).Left = c.Left
        .Shapes(Name).Top = c.Top
        .Shapes(Name).LockAspectRatio = msoTrue
        .Shapes(Name).Height = 100
        .Shapes(Name).Width = 100
        .Range("A1").Select
    End If
......

Afin que la macro puisse effacer cette image nommée "NOUVELLE VERSION BIS", il faut l'introduire manuellement sur ta feuille au préalable, ce que j'ai fait dans le fichier ci-joint. Autrement ta macro va bloquer sur la ligne

.Shapes("NOUVELLE VERSION BIS").Delete

Mais comme je n'ai pas ta banque d'images à disposition, je ne peux pas tester si l'image est bien remplacée. Mais si elle l'est avec l'autre partie du code, elle doit l'être avec cette première partie aussi.

Mon fichier ci-joint comporte cette modification du code.

Le nom de l'image est visible dans la zone de référence :

Alors j'arrive a afficher les deux image sauf que celle de B20 se déplace a cote de celle de G20

Et quand je donne un autre nom (nouvelle version bis) la taille de l'ima est beaucoup trop grande

Peux-tu me fournir un fichier-source dans lequel tu placerais 5 ou 6 photos ?

Tu as les logos avec.

J'ai reussi à afficher les deux en meme temps mais il sont trop large et pas a la place ou je le desire

Ah, enfin tu te décides à me donner les moyens de t'aider mieux

Dans le fichier ci-joint, tu arrives à placer deux images distinctes à deux endroits différents. Si le résultats obtenus n'est pas celui escompté, explique mieux tes soucis. Lorsque tu dis : "J'ai reussi à afficher les deux en meme temps mais il sont trop large et pas a la place ou je le desire", c'est tellement vague que j'ai envie de pleurer. Tu devrais par exemple dire "je souhaiterais que l'image 1 vienne se placer à la hauteur de la cellule X33 et qu'elle soit aussi large que la colonne X alors qu'elle vient se placer à la hauteur de la cellule Z22 et qu'elle remplit deux colonnes".

A propos, connais-tu le pas-à-pas ? Si non, va voir mon fil https://forum.excel-pratique.com/cours-astuces/methodes-point-d-arret-et-pas-a-pas-t59460.html?hilit...

Ca te permettrait de voir ce que chaque ligne de code exécute et de savoir que corriger exactement.

Mais reviens à la charge sur ce fil avec des explications claires si tu ne t'en sors pas tout seul.

Selon moi, les instructions With ActiveSheet/End With ne sont pas très utiles puisque tu déclenches ce code depuis cette feuille et que tu y restes.

Bonsoir, merci a toi d'avoir pris le temps de m'aider.

j'ai tester ton classeur et c'est absolument ce que je recherche.

Sa fonctionne parfaitement pour moi. Sauf que j'aimerai l'image 1 un peu plus a droite. et l'image 2 nettement plus a droite.

Dans mon tableau elle sont placées entre deux cellules.

Au niveau de la position vertical aucun soucis. C'est la position horizontale que je n'arrive pas a régler.

Merci beaucoup

Dans le code ci-joint, j'ai mis en place une correction de la position horizontale.

A toi de tâtonner afin de voir quelle est la bonne valeur de la correction (correction négative = vers la droite, positive = vers la gauche).

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim design As String, c As Range, Nom_Shape As String, Correction As Integer

    If Not Intersect(Target, Range("b4 , g4")) Is Nothing Then
        If Not Intersect(Target, Range("b4")) Is Nothing Then
            design = ThisWorkbook.Path & "/logos/" & [b4].Value & ".png"
            Nom_Shape = "Feuil1"
            Set c = Range("b20").MergeArea
            Correction = -75
        Else
            design = ThisWorkbook.Path & "/logos/" & [g4].Value & ".png"
            Nom_Shape = "Feuil1 BIS"
            Set c = Range("g20").MergeArea
            Correction = -200
        End If

        On Error Resume Next
        Shapes(Nom_Shape).Delete
        Pictures.Insert(design).Name = Nom_Shape
        With Shapes(Nom_Shape)
            .Left = c.Left + Correction
            .Top = c.Top
            .LockAspectRatio = msoTrue
            .Height = 100
            .Width = 100
        End With

        Range("A1").Select

    End If

End Sub

Bien à toi.

merci ! Ca fonctionne parfaitement.

Il me reste plus qu’à changer la cellule B4, et G4 par une cellule qui est sur une autre feuille.

j’ai essayé de mettre (RENCONTRE!B5 à la place mais sa na ps marche.

Merci à toi. Merci beaucoup pour ton aide.

Salut,

Tu auras corrigé toi-même qu'une correction négative = vers la gauche et vice-versa.

Tu es à nouveau très imprécis : tu souhaites encore mon aide ou non ? Si tu as ton travail sur deux feuilles, il aurait mieux valu le dire de suite.

Si tu as besoin d'aide, fournis-moi un fichier avec ta constellation exacte, s'il-te-plait.

Chaleureusement.

Oui c’est juste que le nom, en l’occurrence ceux des Cellules B4 & G4 sont situé sur une autre feuille, en B5 et B55.

J’essaye de le faire tout seul mais je n’y arrive pas.

Yvouille a écrit :

Si tu as besoin d'aide, fournis-moi un fichier avec ta constellation exacte, s'il-te-plait.

oui je te l'ai envoyé en MP