Insertion formes automatiques

**tyndare36** · 21/12/2012, 17h08

Bonjour à tous ou à toutes,

je souhaite savoir s'il est possible insérer dans un tableau des formes automatiques dans une colonne en les sélectionnants dans une liste déroulante ou bien par VBA suivant un critère.
Mon but est de signaler le caractère d'urgence d'une action à mener par un symbole (forme auto.) de différentes couleurs

VERT = PAS DE CARACTÈRE D'URGENCE
ORANGE = URGENCE NORMALE
ROUGE = URGENT
NOIR = TRÈS URGENT

La forme automatique sélectionnée se positionne dans la cellule elle détermine:

soit un besoin de soins par un CROIX
soit un besoin d'alimentation par un CAMEMBERT
soit un besoin de couchage par un CARRE
etc ...

Ces formes peuvent être stockées dans une feuille nommée "PARAMETRE" du classeur par exemple.

merci pour votre aide

**Daniel.C** · 22/12/2012, 17h05

Bonjour,

J'ai écrit ce code avec XL2010. Je ne sais pas s'il fonctionnera avec XL2003. A mettre dans le module de la feuille. Les besooins sont en colonne C et les urgences en colonne E; les icônes en colonne G :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column <> 3 And Target.Column <> 5 Then Exit Sub
    If Cells(Target.Row, 3) <> "" And Cells(Target.Row, 5) <> "" Then
        Forme Target.Row
    End If
End Sub
 
Sub Forme(Ligne)
    Dim Forme As MsoShapeType, Couleur, H As Single
    Dim G As Single, T As Single, Shp As Shape
    H = Cells(Ligne, 7).Height
    G = Cells(Ligne, 7).Left
    T = Cells(Ligne, 7).Top
    On Error Resume Next
    ActiveSheet.Shapes("Forme" & Ligne).Delete
    On Error GoTo 0
    If Cells(Ligne, 5) = "pas urgent" Then
        Couleur = Array(0, 176, 80)
    ElseIf Cells(Ligne, 5) = "assez urgent" Then
        Couleur = Array(255, 192, 0)
    ElseIf Cells(Ligne, 5) = "urgent" Then
        Couleur = Array(255, 0, 0)
    ElseIf Cells(Ligne, 5) = "très urgent" Then
        Couleur = Array(255, 255, 255)
    End If
    Select Case Cells(Ligne, 3).Value
        Case "soins"
            Forme = msoShapeCross
        Case "alimentation"
            Forme = msoShapeOval
        Case "couchage"
            Forme = msoShapeRectangle
    End Select
    Set Shp = ActiveSheet.Shapes.AddShape(Forme, G, T, H, H)
    With Shp
        .Fill.ForeColor.RGB = RGB(Couleur(0), Couleur(1), Couleur(2))
        .Line.Visible = msoFalse
        .Name = "Forme" & Ligne
    End With
End Sub

Regarde le classeur joint.

**tyndare36** · 23/12/2012, 06h32

Bonjour,

Merci pour ton aide

j'ai essayé ton fichier et malheureusement cela ne fonctionne pas; dommage.

voici en PJ le fichier PROJET_CHOIX_LOGOS que je souhaite réaliser.
Puis deux fichiers exemples mais que je n'arrive pas à transposer pour faire fonctionner mon fichier PROJET_CHOIX_LOGOS, et cela je ne comprend pas ou est l'erreur.

merci encore

**tyndare36** · 02/01/2013, 09h21

Je vous souhaite à tous mes meilleurs V B A 2013.
V oeux de
B onne
A nnée
2013

**Philippe Tulliez** · 02/01/2013, 09h54

Bonjour,
Tu as déjà un problème dans ta feuille SUIVI du classeur PROJET_CHOIX_LOGOS.xls.
La Validation de données - Liste est bloquée colonne I. Cette liste fait manifestement référence à un autre classeur nommé Classeur_INSERT IMAGE.xlsm
Quant aux autres colonnes tu n'as mis aucune validation de données.

Bonjour,
Dans le gestionnaire des noms List2 doit faire référence à

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

=DECALER(Logos!$A$2;;;NBVAL(Logos!$A:$A)-1)

ET de plus tu as fait un copier/coller d'un fichier que tu as téléchargé sur le site de Jacques Boisgontier sans en comprendre le code
Dans son classeur la liste est dans la 2ème colonne, chez toi, une des liste est en 9ème colonne. Il y a dons lieu de changer ceci (Ce qui est en rouge)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

  If Target.Column = 9 And Target.Count = 1 Then

Quand tu auras déjà fait ces deux modifications, tu verras déjà que pour la colonne I de la feuille SUIVI cela fonctionne.

**Philippe Tulliez** · 02/01/2013, 14h21

Bonjour Daniel,

Envoyé par Daniel.C

Bonjour,
J'ai écrit ce code avec XL2010. Je ne sais pas s'il fonctionnera avec XL2003. A mettre dans le module de la feuille. Les besooins sont en colonne C et les urgences en colonne E; les icônes en colonne G :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column <> 3 And Target.Column <> 5 Then Exit Sub
    If Cells(Target.Row, 3) <> "" And Cells(Target.Row, 5) <> "" Then
        Forme Target.Row
    End If
End Sub
Sub Forme(Ligne)
    Dim Forme As MsoShapeType, Couleur, H As Single
    Dim G As Single, T As Single, Shp As Shape
    H = Cells(Ligne, 7).Height
    G = Cells(Ligne, 7).Left
    T = Cells(Ligne, 7).Top
    On Error Resume Next
    ActiveSheet.Shapes("Forme" & Ligne).Delete
    On Error GoTo 0
    If Cells(Ligne, 5) = "pas urgent" Then
        Couleur = Array(0, 176, 80)
    ElseIf Cells(Ligne, 5) = "assez urgent" Then
        Couleur = Array(255, 192, 0)
    ElseIf Cells(Ligne, 5) = "urgent" Then
        Couleur = Array(255, 0, 0)
    ElseIf Cells(Ligne, 5) = "très urgent" Then
        Couleur = Array(255, 255, 255)
    End If
    Select Case Cells(Ligne, 3).Value
        Case "soins"
            Forme = msoShapeCross
        Case "alimentation"
            Forme = msoShapeOval
        Case "couchage"
            Forme = msoShapeRectangle
    End Select
    Set Shp = ActiveSheet.Shapes.AddShape(Forme, G, T, H, H)
    With Shp
        .Fill.ForeColor.RGB = RGB(Couleur(0), Couleur(1), Couleur(2))
        .Line.Visible = msoFalse
        .Name = "Forme" & Ligne
    End With
End Sub

Regarde le classeur joint.

Bravo pour ce code.
Je te confirme que cela fonctionne parfaitement sur la version 2003.

**tyndare36** · 02/01/2013, 16h20

Milles excuses pour le fichier Tyndare36.xls de Daniel.C effectivement il fonctionne. Il est fort possible que dans mon énervement et mon ignorance à faire fonctionner le reste j’ai pu essayer de le faire fonctionner alors que tout était bloqué. Je vous prie Daniel.C d’accepter mes excuses.

Philippe Tulliez il est vrai que dans mes innombrables essais j’ai commis des erreurs. Je viens de les corriger et là ma première colonne (la N°9) fonctionne mais pas les autres (N°11 ; 13 ; et 15) elles ne fonctionnent pas.
Maintenant il est vrai que mon ignorance est grande en VBA et donc j’ai recopié le code pour chaque colonne les uns à la suite des autres (la fonction F8 ne me permet pas de faire du pas à pas).

Si je sépare les lignes de code en plusieurs macros le résultat indique
« Erreur compilation
Nom ambigu détecté : Worksheet_change »

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
Private Sub Worksheet_Change(ByVal Target As Range)
  Set images = Sheets("logos")
 
  'LISTE2 =0=0=0=0=0=0=0=0=0=0=0=
 
  If Target.Column = 9 And Target.Count = 1 Then
    '-- suppression
    For Each s In ActiveSheet.Shapes
      If s.Type = 13 Then
        If s.TopLeftCell.Address = Target.Address Then s.Delete
      End If
    Next s
    If Target <> "" Then
      On Error Resume Next
      images.Shapes(Target).Copy
      If Err = 0 Then
        ActiveSheet.Paste
        Selection.OnAction = "ClicImage2"
        Selection.Name = "Image" & ActiveCell.Row
        largeurImage = images.Shapes(Target).Width
        HauteurImage = images.Shapes(Target).Height + 6
        Selection.ShapeRange.Left = ActiveCell.Left + ActiveCell.Width / 2 - largeurImage / 2
        Selection.ShapeRange.Top = ActiveCell.Top + 5
        Rows(Target.Row).RowHeight = HauteurImage + 10
        Target.Select
      End If
    End If
 
 'LISTE3 =0=0=0=0=0=0=0=0=0=0=0=
 
     If Target.Column = 11 And Target.Count = 1 Then
    '-- suppression
    For Each s In ActiveSheet.Shapes
      If s.Type = 13 Then
        If s.TopLeftCell.Address = Target.Address Then s.Delete
      End If
    Next s
    If Target <> "" Then
      On Error Resume Next
      images.Shapes(Target).Copy
      If Err = 0 Then
        ActiveSheet.Paste
        Selection.OnAction = "ClicImage2"
        Selection.Name = "Image" & ActiveCell.Row
        largeurImage = images.Shapes(Target).Width
        HauteurImage = images.Shapes(Target).Height + 6
        Selection.ShapeRange.Left = ActiveCell.Left + ActiveCell.Width / 2 - largeurImage / 2
        Selection.ShapeRange.Top = ActiveCell.Top + 5
        Rows(Target.Row).RowHeight = HauteurImage + 10
        Target.Select
      End If
    End If
 
 'LISTE4 =0=0=0=0=0=0=0=0=0=0=0=
 
 
     If Target.Column = 13 And Target.Count = 1 Then
    '-- suppression
    For Each s In ActiveSheet.Shapes
      If s.Type = 13 Then
        If s.TopLeftCell.Address = Target.Address Then s.Delete
      End If
    Next s
    If Target <> "" Then
      On Error Resume Next
      images.Shapes(Target).Copy
      If Err = 0 Then
        ActiveSheet.Paste
        Selection.OnAction = "ClicImage2"
        Selection.Name = "Image" & ActiveCell.Row
        largeurImage = images.Shapes(Target).Width
        HauteurImage = images.Shapes(Target).Height + 6
        Selection.ShapeRange.Left = ActiveCell.Left + ActiveCell.Width / 2 - largeurImage / 2
        Selection.ShapeRange.Top = ActiveCell.Top + 5
        Rows(Target.Row).RowHeight = HauteurImage + 10
        Target.Select
      End If
    End If
 
 
 'LISTE5 =0=0=0=0=0=0=0=0=0=0=0=
 
 
     If Target.Column = 15 And Target.Count = 1 Then
    '-- suppression
    For Each s In ActiveSheet.Shapes
      If s.Type = 13 Then
        If s.TopLeftCell.Address = Target.Address Then s.Delete
      End If
    Next s
    If Target <> "" Then
      On Error Resume Next
      images.Shapes(Target).Copy
      If Err = 0 Then
        ActiveSheet.Paste
        Selection.OnAction = "ClicImage2"
        Selection.Name = "Image" & ActiveCell.Row
        largeurImage = images.Shapes(Target).Width
        HauteurImage = images.Shapes(Target).Height + 6
        Selection.ShapeRange.Left = ActiveCell.Left + ActiveCell.Width / 2 - largeurImage / 2
        Selection.ShapeRange.Top = ActiveCell.Top + 5
        Rows(Target.Row).RowHeight = HauteurImage + 10
        Target.Select
      End If
       End If
 
      End If
 
     End If
 
    End If
 
   End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
 'LISTE2 =0=0=0=0=0=0=0=0=0=0=0=
 
  If Target.Column = 9 And Target.Count = 1 Then
    If Not Intersect(Target, Cells.SpecialCells(xlCellTypeAllValidation)) Is Nothing Then
      SendKeys "%{down}"
    End If
 
 'LISTE3 =0=0=0=0=0=0=0=0=0=0=0=
 
      If Target.Column = 11 And Target.Count = 1 Then
    If Not Intersect(Target, Cells.SpecialCells(xlCellTypeAllValidation)) Is Nothing Then
      SendKeys "%{down}"
    End If
 
 'LISTE4 =0=0=0=0=0=0=0=0=0=0=0=
 
        If Target.Column = 13 And Target.Count = 1 Then
    If Not Intersect(Target, Cells.SpecialCells(xlCellTypeAllValidation)) Is Nothing Then
      SendKeys "%{down}"
    End If
 
 'LISTE5 =0=0=0=0=0=0=0=0=0=0=0=
 
        If Target.Column = 15 And Target.Count = 1 Then
    If Not Intersect(Target, Cells.SpecialCells(xlCellTypeAllValidation)) Is Nothing Then
      SendKeys "%{down}"
    End If
 
         End If
       End If
     End If
  End If
End Sub

Merci encore pour votre aide et BONNE ANNÉE 2013

**Daniel.C** · 02/01/2013, 16h47

Milles excuses pour le fichier Tyndare36.xls de Daniel.C effectivement il fonctionne. Il est fort possible que dans mon énervement et mon ignorance à faire fonctionner le reste j’ai pu essayer de le faire fonctionner alors que tout était bloqué. Je vous prie Daniel.C d’accepter mes excuses.

Il n'y a pas d'offense, tout le monde peut se tromper. Et bon courage, mais avec Philippe, tu m'as l'air bien parti.

**Philippe Tulliez** · 02/01/2013, 20h33

Bonjour,

Envoyé par tyndare36

Philippe Tulliez il est vrai que dans mes innombrables essais j’ai commis des erreurs. Je viens de les corriger et là ma première colonne (la N°9) fonctionne mais pas les autres (N°11 ; 13 ; et 15) elles ne fonctionnent pas.
Maintenant il est vrai que mon ignorance est grande en VBA et donc j’ai recopié le code pour chaque colonne les uns à la suite des autres (la fonction F8 ne me permet pas de faire du pas à pas).
Si je sépare les lignes de code en plusieurs macros le résultat indique
« Erreur compilation
Nom ambigu détecté : Worksheet_change »

S'il y a plusieurs tests logiques, il faut utiliser une procédure décisionnelle, SELECT CASE, IF ou autres ou une opération booléenne avec AND ou OR.
Je n'ai malheureusement pas le temps pour l'instant de regarder à cela.

Bonjour,
Voici un exemple de code pour vérifier si l'utilisateur à bien modifié la cellule des colonnes C, E, ou F ET qu'il s'agit bien d'une modification sur une seule cellule.
Code se trouvant dans l'objet feuille où a lieu la modification.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Count = 1 Then ' Vérifie si le changement se fait sur une cellule
  Select Case Target.Column
   Case 3, 5, 7 ' Vérifie si c'est bien les colonnes 3, 5 et 7
       ' Ici le code    
       MsgBox "Oui ici le code"
  End Select
 End If
End Sub

**tyndare36** · 05/01/2013, 12h14

Bonjour,

J'ai essayé le code de Philippe mais j'ai un message d'erreur:

"Erreur de Compilation:
End sélect sans Select Case"

J'ai un Select Case Target.Column en ligne N°3

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Count = 1 Then ' Vérifie si le changement se fait sur une cellule
  Select Case Target.Column
   Case 9, 11, 13, 15 ' Vérifie si c'est bien les colonnes 3, 5 et 7
       ' Ici le code
 
       If Target <> "" Then
      On Error Resume Next
      images.Shapes(Target).Copy
      If Err = 0 Then
        ActiveSheet.Paste
        Selection.OnAction = "ClicImage2"
        Selection.Name = "Image" & ActiveCell.Row
        largeurImage = images.Shapes(Target).Width
        HauteurImage = images.Shapes(Target).Height + 6
        Selection.ShapeRange.Left = ActiveCell.Left + ActiveCell.Width / 2 - largeurImage / 2
        Selection.ShapeRange.Top = ActiveCell.Top + 5
        Rows(Target.Row).RowHeight = HauteurImage + 10
        Target.Select
       MsgBox "Oui ici le code"
  End Select
 End If
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
 'LISTE2 =0=0=0=0=0=0=0=0=0=0=0=
 
  If Target.Column = 9 And Target.Count = 1 Then
    If Not Intersect(Target, Cells.SpecialCells(xlCellTypeAllValidation)) Is Nothing Then
      SendKeys "%{down}"
    End If
 
 'LISTE3 =0=0=0=0=0=0=0=0=0=0=0=
 
      If Target.Column = 11 And Target.Count = 1 Then
    If Not Intersect(Target, Cells.SpecialCells(xlCellTypeAllValidation)) Is Nothing Then
      SendKeys "%{down}"
    End If
 
 'LISTE4 =0=0=0=0=0=0=0=0=0=0=0=
 
        If Target.Column = 13 And Target.Count = 1 Then
    If Not Intersect(Target, Cells.SpecialCells(xlCellTypeAllValidation)) Is Nothing Then
      SendKeys "%{down}"
    End If
 
 'LISTE5 =0=0=0=0=0=0=0=0=0=0=0=
 
        If Target.Column = 15 And Target.Count = 1 Then
    If Not Intersect(Target, Cells.SpecialCells(xlCellTypeAllValidation)) Is Nothing Then
      SendKeys "%{down}"
    End If
 
         End If
       End If
     End If
  End If
End Sub

Je suis désolé mais je ne suis pas très doué

Merci

Insertion formes automatiques [XL-2003]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager