Mettre un shape dans une cellule avec condition

[libellule85]

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.

 

[job75]

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+

 

[libellule85]

Bonjour Job75,

Effectivement je n'avais pas pensé à cela, il va falloir que je crée au moins 52 shapes, et concernant l'effacement d'"AM" je ne sais pas trop !

 

[pierrejean]

Bonjour libellule
Salut Gerard

Pour créer les Shapes
Par contre pour supprimer !!!!! (je cherche)

 

[Modeste geedee]

Bonsour®

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.

Pourquoi faire une usine à gaz ...
utiliser les MEFC

 

[pierrejean]

Salut Modeste

Et si on aime les usines à gaz !!!!
Une méthode capillotractée pour supprimer les shapes : remplacer le nom dans la colonne A par ""

 

[job75]

Re, salut Pierre, Modeste geedee,

Pas encore regardé ton code Pierre.

Voyez le fichier joint et ce code dans la 1ère feuille :

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+

 

[pierrejean]

Re

Superbe !!! Gerard

 

[Modeste geedee]

Bonsour®

Voyez le fichier joint et ce code dans la 1ère feuille :

pour continuer dans ce sens

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

 

[Modeste geedee]

Bonsour® PierreJean, Nicole, Job75, libellule85

Et si on aime les usines à gaz !!!!

en l'attente de réponse du demandeur (question à tiroirs) et dans le domaine des élucubrations, je peux toujours répondre : "présent"

 

[libellule85]

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.

 

[libellule85]

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.

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

 

[Modeste geedee]

Bonsour®

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.

c'est que j'ai proposé là :
https://www.excel-downloads.com/thr...ellule-avec-condition.20014453/#post-20108132

 

[libellule85]

Bonsoir Modeste geedee,

Je suis vraiment nulle, je m'étais focalisée sur la solution de job75 ! Je te présente toutes mes excuses

 

[job75]

Bonsoir libellule85, bonsoir les autres,

Nommez AM et PM les formes sources et modifiez 2 lignes de la macro :

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+