Insertion formes automatiques

Version imprimable

21/12/2012, 17h08
tyndare36

Insertion formes automatiques
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
1. VERT = PAS DE CARACTÈRE D'URGENCE
2. ORANGE = URGENCE NORMALE
3. ROUGE = URGENT
4. 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

1 pièce(s) jointe(s)

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:

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.

23/12/2012, 06h32
tyndare36

3 pièce(s) jointe(s)

Insertion formes automatiques

Bonjour,

Merci pour ton aide

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

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. :arf:

merci encore
02/01/2013, 09h21
tyndare36

Insertion formes automatiques

Je vous souhaite à tous mes meilleurs V B A 2013.
V oeux de
B onne
A nnée
2013
:ccool:
02/01/2013, 09h54
Philippe Tulliez

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:

=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:

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.

Bonjour Daniel,

Citation:

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:

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.

1 pièce(s) jointe(s)

Insertion formes automatiques

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:

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

02/01/2013, 16h47
Daniel.C

Citation:

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.

Bonjour,

Citation:

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:

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

1 pièce(s) jointe(s)

Insertion formes automatiques

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:

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

05/01/2013, 13h21
Philippe Tulliez
Bonjour,

Citation:

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

Tu veux plutôt dire que tu as une erreur après avoir insérer le bout de code que j'ai publié dans le tien :roll:. Parce-que je teste toujours les codes avant publication
Ton erreur vient du fait que tu as oublié de placer un END IF après ces deux lignes.
Code:

1 2 Target.Select MsgBox "Oui ici le code"
Un IF doit se terminer par un END IF et un SELECT par un END SELECT.
Il faut indenter ton code pour mieux le visualiser.
05/01/2013, 17h56
tyndare36

Insertion formes automatiques

Bonsoir

Oui bien entendu j'ai essayé d'utiliser ton code pour arriver à mes fins.

Mais même après l'ajout d'un End IF j'ai le même message d'erreur :arf:
05/01/2013, 18h37
Daniel.C

Bonjour,

Euh il en manque un autre, à mon avis. Dans le code que tu as posté, il en manquait un pour :

Code:

If Target <> "" Then

et un pour :

Code:

If Err = 0 Then

Comme te l'a dit Philippe, indente ton code.
05/01/2013, 19h52
tyndare36

Bonsoir Daniel
J’ai rajouté un End IF et plus de message d’erreur. Mais cela ne fonctionne pas pour autant.
Que signifie « indente »

Citation:

Comme te l'a dit Philippe, indente ton code.

Merci pour vos aides.

Je n'ai pas étudié le code, je ne sais pas pourquoi il ne fonctionne pas. Indenter du code, c'est décaler logiquement "en dents" les lignes de code. Ainsi, tu peux contrôler plus facilement s'il manque quelque chose. Ci dessous la même macro, l'une avec du code indenté :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub ExemplePasIndenté()
With Sheets("Feuil1")
Select Case .[A1].Value
Case 1
If .[B1] = 2 Then
MsgBox "toto"
Else
MsgBox "titi"
End If
Case 2
If .[B1] = 2 Then
MsgBox "tutu"
Else
MsgBox "tata"
End If
End Select
End With
End Sub

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub ExempleIndentation()
    With Sheets("Feuil1")
        Select Case .[A1].Value
            Case 1
                If .[B1] = 2 Then
                    MsgBox "toto"
                Else
                    MsgBox "titi"
                End If
            Case 2
                If .[B1] = 2 Then
                    MsgBox "tutu"
                Else
                    MsgBox "tata"
                End If
        End Select
    End With
End Sub

06/01/2013, 11h45
Philippe Tulliez

Bonjour,
J'ajouterais à l'intervention de Daniel que je salue au passage qu'il est aisé d'indenter un bloc d'instruction dans l'éditeur en sélectionnant les instructions à indenter et ensuite appuyer sur la touche TAB et Back Tab pour l'inverse. Cela a pour effet de faire avancer ou reculer les lignes sélectionnées d'un certain nombres de caractères.
Ce nombre de caractères est par défaut à 8 je pense et peut être modifié en allant changer l'option largeur de la tabulation dans Outils/Options - [Editeur].
Pour ma part, je la place à 1 ou à 2 selon les circonstances.
06/01/2013, 12h56
mercatog

Bonjour à tous
Sur la même lancée que Philippe et Daniel, ici un Add-Ins à installer (au cas où tu as les droits). Un clique droit et tu pourra indenter tout ton projet
http://www.developpez.net/forums/new...te=1&p=7056444