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
|
Public Sub AfficherCouleur(Index As Integer)
Dim PlageAssos As Range
Dim Cel As Range
Dim Couleur As String
'variables statique pour l'appairage
Static Pos As Integer
Static Img1 As Integer
Static Img2 As Integer
'si les deux variables ont déjà été initialisées, les remet à 0
If Img1 <> 0 And Img2 <> 0 Then Img1 = 0: Img2 = 0
'incrémente pour l'appairage
Pos = Pos + 1
'affecte l'index en fonction de la position ordinale de l'image dans la paire
If Pos = 1 Then Img1 = Index
If Pos = 2 Then Img2 = Index
'si la paire est constituée :
If Pos = 2 Then
Worksheets("Feuil4").Activate
'remet à 0 pour la prochaine paire
Pos = 0
'défini la plage pour la recherche de la couleur
With Worksheets("Feuil3")
Set PlageAssos = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
'boucle sur la plage à la recherche de la paire et récupère le nom de la couleur
'Attention, les valeurs doivent être entrées comme dans l'exmple --> 2+3 vert foncé
For Each Cel In PlageAssos
If Img1 = Left(Cel, 1) And Img2 = Mid(Cel, 3, 1) Then
Couleur = Cel.Offset(, 1)
Exit For 'si trouvé, fin de boucle
End If
Next Cel
End If
'si la couleur est définie, l'inscrit en colonne A de "Feuil4" à la suite
If Couleur <> "" Then
With Worksheets("Feuil4")
.Range("A" & .Cells(.Rows.Count, 1).End(xlUp).Row + 1) = Couleur
Colorer .Range("A" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<-- colore la cellule d'à coté
End With
Couleur = ""
End If
End Sub
Sub Colorer(Cel As Range)
Dim Tbl
Dim I As Integer
'nom des couleurs (à adpater si ne convient pas !)
Tbl = Array("NOIR", "BLANC", "ROUGE", "VERT BRILLANT", "BLEU", "JAUNE", _
"ROSE", "TURQUOISE", "ROUGE FONCÉ", "VERT", "BLEU FONCÉ", _
"MARRON CLAIR", "VIOLET", "BLEU-VERT", "GRIS-25%", "GRIS-50%", _
"LAVANDE FONCÉ", "VIOLET-MAUVE", "JAUNE PALE", "BLEU TRÈS CLAIR", _
"PRUNE FONCÉ", "SAUMON FONCÉ", "BLEU GRIS", "MAUVE CLAIR", _
"BLEU TRÈS FONCÉ", "ROSE FONCÉ", "JAUNE BRILLANT", "TURQUOISE BRILLANT", _
"VIOLET BRILLANT", "ROUGE MARRON", "BLEUR-VERT CLAIR", "BLEU BRILLANT", _
"BLEU CIEL", "TURQUOISE CLAIR", "VERT CLAIR", "JAUNE CLAIR", "BLEU MOYEN", _
"SAUMON", "LAVANDE", "BRUN", "BLEU CLAIR", "VERT D'EAU", "CITRON VERT", _
"OR", "ORANGE CLAIR", "ORANGE", "BLEU GRIS", "GRIS-40%", "BLEU-VERT FONCÉ", _
"VERT MARIN", "VERT FONCÉ", "VERT OLIVE", "MARRON", "PRUNE", "INDIGO", "GRIS-80%")
For I = 1 To UBound(Tbl)
If Tbl(I) = Cel Then
Cel.Offset(, 1).Interior.ColorIndex = I + 1
Exit Sub
End If
Next I
End Sub
'Cette procédure affecte un appel à la macro "AfficherCouleur"
'en passant le nombre attaché à l'image en argument
'NOTE : Une fois toutes les images positionnées sur la feuille, cette proc
'a besoin de n'être exécutée qu'une seule fois
Sub ActionImages()
Dim action As String
Dim Img As Shape
Dim I As Integer
For Each Img In Worksheets("Feuil1").Shapes
If Img.Type = 13 Then
'extrait le numéro de l'image pour le passer en argument à OnAction
action = "'AfficherCouleur""" & Split(Img.Name, "_")(1) & "'"
Img.OnAction = action
End If
Next Img
Set Img = Nothing
End Sub |
associer des liens hypertexte par macro
Répondre avec citation
Partager