Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Mettre un shape dans une cellule avec condition

Créer une discussion

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 !

S'inscrire

libellule85

XLDnaute Accro
Bonjour le forum,

J'aimerais quand j'écris par exemple AM dans une cellule qu'un shape ou une forme vienne se mettre dans la cellule qui a été renseignée de cette façon. Et si on supprime AM le shape ou la forme disparaisse de la cellule.
Je pense que le vba est la meilleure solution !
D'avance merci beaucoup pour votre aide.
 

Pièces jointes

Trier par date Trier par votes
Bonjour libellule85,

Juste 2 questions à 100 sous :

- faut-il autant de Shapes qu'il y a de cellules "AM" ou une seule qu'on déplace sur la dernière entrée ?

- comment voulez-vous faire pour effacer "AM" une fois que la Shape la recouvre ?

A+
 
Vote positif 0 Vote négatif
Bonsour® Pourquoi faire une usine à gaz ...
utiliser les MEFC
 

Pièces jointes

Vote positif 0 Vote négatif
Re, salut Pierre, Modeste geedee,

Pas encore regardé ton code Pierre.

Voyez le fichier joint et ce code dans la 1ère feuille :
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Set r = Intersect(Target, Me.UsedRange)
If r Is Nothing Then Exit Sub
Application.ScreenUpdating = False
For Each r In r 'si entrées multiples
  If LCase(r) = "am" Then
    Feuil2.Shapes(1).Copy 'CodeName de la feuille source
    Me.Paste
    With Selection
      .Left = r.Left
      .Top = r.Top
      .Name = r.Address
    End With
  End If
Next
ActiveCell.Activate
End Sub

Sub Effacer()
On Error Resume Next
Range(Application.Caller) = ""
Shapes(Application.Caller).Delete
End Sub
A+
 

Pièces jointes

Vote positif 0 Vote négatif
Bonsour®
job75 à dit:
Voyez le fichier joint et ce code dans la 1ère feuille :
Cliquez pour agrandir...
pour continuer dans ce sens 🙄

VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Set r = Intersect(Target, Me.UsedRange)
If r Is Nothing Then Exit Sub
Application.ScreenUpdating = False
For Each r In r 'si entrées multiples
  If LCase(r) = "am" Then
    Feuil2.Shapes(1).Copy 'CodeName de la feuille source
    Me.Paste
    With Selection
      .Left = r.Left
      .Top = r.Top
      .Name = r.Address
    End With
  End If
  If LCase(r) = "pm" Then
    Feuil2.Shapes(2).Copy 'CodeName de la feuille source
    Me.Paste
    With Selection
      .Left = r.Left
      .Top = r.Top
      .Name = r.Address
    End With
  End If
  If LCase(r) = "nuit" Then
    Feuil2.Shapes(3).Copy 'CodeName de la feuille source
    Me.Paste
    With Selection
      .Left = r.Left
      .Top = r.Top
      .Name = r.Address
    End With
  End If
  If LCase(r) = "jour" Then
    Feuil2.Shapes(4).Copy 'CodeName de la feuille source
    Me.Paste
    With Selection
      .Left = r.Left
      .Top = r.Top
      .Name = r.Address
    End With
  End If
Next
ActiveCell.Activate
End Sub
 
Vote positif 0 Vote négatif
Bonsoir pierrejean, Modes Geedee, Bisson Nicole, Re job75,

Je suis sur une autre planète, avec toutes vos super réponses ! Je voulais tous vous adresser un grand grand merci d'avoir pris du temps pour moi.
Je vais regarder de plus près toutes vos réponses et je reviens vers vous.
 
Vote positif 0 Vote négatif
Bonsoir le forum,
Je reviens vers vous et plus particulièrement vers job75 et sa solution en post #7 : par contre peut-on mettre un choix dans la même macro ? Si on tape AM c'est le triangle 1 et si on tape PM c'est le triangle 2 qui s'affiche, est ce possible ?
D'avance merci pour votre aide.

VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Set r = Intersect(Target, Me.UsedRange)
If r Is Nothing Then Exit Sub
Application.ScreenUpdating = False
For Each r In r 'si entrées multiples
  If LCase(r) = "am" Then
    Feuil2.Shapes(1).Copy 'CodeName de la feuille source
    Me.Paste
    With Selection
      .Left = r.Left
      .Top = r.Top
      .Name = r.Address
    End With
  End If
Next
ActiveCell.Activate
End Sub

Sub Effacer()
On Error Resume Next
Range(Application.Caller) = ""
Shapes(Application.Caller).Delete
End Sub
 
Vote positif 0 Vote négatif
Vote positif 0 Vote négatif
Bonsoir libellule85, bonsoir les autres,

Nommez AM et PM les formes sources et modifiez 2 lignes de la macro :
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Set r = Intersect(Target, Me.UsedRange)
If r Is Nothing Then Exit Sub
Application.ScreenUpdating = False
For Each r In r 'si entrées multiples
  If LCase(r) = "am" Or LCase(r) = "pm" Then
    Feuil2.Shapes(r).Copy 'CodeName de la feuille source
    Me.Paste
    With Selection
      .Left = r.Left
      .Top = r.Top
      .Name = r.Address
    End With
  End If
Next
ActiveCell.Activate
End Sub
A+
 

Pièces jointes

Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- 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ésolu(e)
XL 2019 Adapter ce code, et améliorer le tableau avec graphique à l'année à y insérer ?
Réponses
4
Affichages
417
sylvanu
N
  • Résolu(e)
XL 2010 A partir d’un Shape, ouvrir un fichier dont l'adresse est sur une autre feuille dans une cellule
Réponses
4
Affichages
482
Nounours_59
N
A
  • Question Question
Microsoft 365 Vérifier si un texte existe dans une cellule contenant une liste
Réponses
9
Affichages
519
arzac
A
T
  • Question Question
XL 2019 pied de page = insérer contenu cellule
Réponses
4
Affichages
280
wDog66
W
G
  • Question Question
Microsoft 365 Résultat dans une cellule en fonction d'une autre cellule
Réponses
1
Affichages
180
vgendron
M
  • Question Question
Microsoft 365 Chercher dernière valeur d'une ligne mais avec une particularité
Réponses
4
Affichages
239
Marie.
M
R
  • Question Question
Microsoft 365 aide recherche multiple entrées d'une cellule dans colonne
2
Réponses
16
Affichages
1 K
richard31
R
P
  • Résolu(e)
XL 2021 Comment détecter la modification MANUELLE d'une cellule dans une feuille ?
Réponses
3
Affichages
250
PRy
P
A
  • Résolu(e)
XL 2021 Ajustement automatique d'une référence cellule dans une macro ?
Réponses
2
Affichages
346
Alamyr
A
  • Question Question
XL 2013 enregistrer la capture d'une shape avec les api avec transparence
2
Réponses
26
Affichages
2 K
patricktoulon
M
  • Question Question
XL 2021 Fichier partagé - erreur de l'objet TextRange2
Réponses
7
Affichages
488
macseb
M
P
  • Résolu(e)
Microsoft 365 Suppression lignes par rapport à une date
2 3 4
Réponses
50
Affichages
1 K
pierrof
P
W
  • Question Question
Microsoft 365 compter le nombre d'articles expédiés un jour donné
Réponses
2
Affichages
221
Wilmouth Michel
W
  • Question Question
XL 2019 Mettre un chiffre positif ou négatif en fonction de la case du texte
Réponses
9
Affichages
290
frelon71
W
  • Résolu(e)
XL 2016 Placer mes photos dans la colonne A, [A3], [A4],etc, jusqu'en [A99] selon le prénom et le nom colonnes B et C
2
Réponses
26
Affichages
1 K
Webperegrino
W
D
  • Résolu(e)
Microsoft 365 chercher une cellule de couleur rouge dans une colonne
Réponses
4
Affichages
402
sylvanu
C
  • Question Question
XL 2021 Mettre en couleur cellule avec une mêmes informations
Réponses
3
Affichages
294
Ckyara31
C
Y
  • Résolu(e)
XL 2013 Bloquer la saisie dans une plage selon un critère
Réponses
6
Affichages
624
TooFatBoy
K
  • Résolu(e)
XL 2010 Roulement automatique
Réponses
9
Affichages
264
komarlehomard
K
  • Question Question
XL 2016 [RESOLU]Affichage texte et résultat d'une cellule dans une forme
Réponses
3
Affichages
285
nrdz83
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…