Discussion :

[010714]

J'ai réussi a faire fonctionner le programme de rangement automatique, maintenant je me heurt a un autre probleme.
J'ai écrit le code suivant :

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
Dim nbLigne As Integer
With Worksheets("Rapport mensuel")
    nbLigne = .Range("A" & .Rows.Count).End(xlUp).Row 'compte en partant de A1 le nombre de lignes non vide
End With
a = [A4].Resize(nbLigne).Value 'A1 si on veut garder l'entête
    Dim j As Integer
    Dim b As Variant, i As Long
For k = 1 To nbLigne
    b = Split(a(k, 1), "    ") 'séparer les mots espacés de 4 espaces
         For i = 0 To UBound(b) 'chaque mots de la phrase
            For j = i + 2 To UBound(b) + 2
    Cells(k, j).Value = b(i) 'ranger dans la cellule de droite le mot
            Next j
        Next i
Next k

L'idée est que j'ai une chaine de caractère dans la cellule A5 par exemple :

---    ---    06/05/2014 02:01:21    ---    ---    ---    ---    OK

ou encore :

M1-ZONE 1    13 Rouleau    30/05/2014 03:32:26    ---    ---    Contrôle - Alerte    ---    OK

Je cherche à casser cette chaine ou les "groupes mots" sont séparés par 4 espaces.
Je veux que chacun des "groupes de mots" ce retroue dans la cellule de droite à la ligne 2 :
exemple :

B2:"---"
C2:"---"
D2:"06/05/2014 02:01:21"
E2:"---"
F2:"---"
G2:"---"
H2:"---"
I2:"OK"

Le probleme dans mon programme c'est qu'il extrait par exemple "M1-ZONE1", il le colle dans les cellules B2 à I2, ensuite il extrait "13 Rouleau", le colle dans les cellules C2 à I2 etc. jusqu'a coller "OK" en I2... (c'est très long).

Comment faire pour simplement séparer la chaine de "mots" et coller uniquement la partie qu'il faut a sa place, cela me permetterais un gain de temps énorme.

Dans l'attente de votre aide

[Theze]

Bonjour,

J'ai un peu retouché ton code concernant la proc "Rapport_Mensuel", j'ai supposé que la feuille visée dans ton classeur est la feuille "Exemple données Feuil2".
Regarde le résultat si il correspond à ton attente, je regarderai la proc "Suivi_Rondes" un peu plus tard en fonction du retour que tu me donne.
Le nom des variables est assez important dans un code afin qu'il soit plus clair à lire et surtout à maintenir. Il n'est pas nécessaire de créer une variable pour chaque utilisation, tu peux utiliser une variable existante qui à déjà été utilisée et qui ne l'ai plus pour la suite du code, ceci prend moins de place en mémoire. Le fait de déclarées les variables en début de proc permet une meilleure clarté !
Je n'ai pas suivis le fil de la discussion, je suis parti de ton premier code pour la modif :

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
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
 
Sub Rapport_Mensuel()
 
    'variables objet
    Dim Feuille As Worksheet
    Dim Plage As Range
    Dim Cel As Range
 
    'variable pour la dernière ligne non vide
    Dim Ligne As Long
 
    'variable compteurs
    Dim I As Long
    Dim j As Long
    Dim K As Long
 
    'tableaux variants
    Dim Tblo_A
    Dim Tblo_B
 
    'gèle la mise à jour
    Application.ScreenUpdating = False
 
    'pour que la référence à la feuille visée soit bien claire...
    Set Feuille = Worksheets("Exemple données Feuil2")
 
    'fait référence à la feuille
    With Feuille
 
        On Error Resume Next
        'remplace les caracteres "," par "."
        .Cells.SpecialCells(xlCellTypeConstants).Replace ",", "."
 
        'Efface "Hiérarchie"
        .Cells.SpecialCells(xlCellTypeConstants).Replace "Hiérarchie / ", ""
 
        On Error GoTo 0
 
        Ligne = .Cells(.Rows.Count, 1).End(xlUp).Row
 
        Tblo_A = .Cells(4, 1).Resize(Ligne).Value 'A1 si on veut garder l'entête
 
        For K = 1 To Ligne
 
            Tblo_B = Split(Tblo_A(K, 1), "    ") 'séparer les mots espacés de 4 espaces
 
            For I = 0 To UBound(Tblo_B) 'chaque mots de la phrase
 
                For j = I + 2 To UBound(Tblo_B) + 2
 
                    .Cells(K, j).Value = Tblo_B(I) 'ranger dans la cellule de droite le mot
 
                Next j
 
            Next I
 
        Next K
 
        .Columns("A:A").Delete Shift:=xlToLeft 'supprimer la 1ère colonne de données collés
        .Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'efface toutes les lignes vides
        .Columns("A:K").HorizontalAlignment = xlCenter 'centrer le texte
        .Columns("D:E").NumberFormat = "General"
 
        Set Plage = .Range(.Cells(1, 1), .Cells(.Rows.Count, 3).End(xlUp))
 
        For Each Cel In Plage
 
           If Cel.Value = "---" Then Cel.Value = Cel.Offset(-1, 0).Value 'Si la cellule contient "---", elle prend la valeur de celle du dessus
 
        Next Cel
 
        'recherche la dernière cellule utilisée sur toutes les colonnes
        Ligne = .Cells.Find("*", .Range("A1"), xlFormulas, , 1, 2).Row
 
        For I = Ligne To 1 Step -1
 
            If .Cells(I, 6) Like "---" And .Cells(I, 8) Like "---" Then .Rows(I).Delete 'efface les lignes si il y a "---" dans les colonnes F et H
            If .Cells(I, 8) Like "OK" Or .Cells(I, 8) Like "Ensemble OK" Then .Rows(I).Delete  'efface les lignes si il y a "OK" ou "Ensemble OK" dans les colonnes F et H
            If .Cells(I, 1) Like " " Then .Rows(I).Delete 'efface les lignes contenant " " bug?
            If .Cells(I, 3) Like "Machine à l'arrêt" Then .Rows(I).Delete 'efface les lignes ou la colonne 3 contient "Machine à l'arrêt"
 
            'rajouter les differents cas qui ne sont pas en alerte...
 
        Next I
 
        Set Plage = .Range(.Cells(1, 6), .Cells(.Rows.Count, 6).End(xlUp))
 
        For Each Cel In Plage
 
           If Cel.Value = "---" Then Cel.Value = Cel.Offset(-1, 0).Value 'Si la cellule dans la colonne F contient "---", elle prend la valeur de celle du dessus
 
        Next Cel
 
        Ligne = .Cells(.Rows.Count, 3).End(xlUp).Row
 
        'Met sous la forme dd/mm/yyyy la date
        For I = 1 To Ligne
 
            If IsDate(Cells(I, 2)) Then
 
                .Cells(I, 2).NumberFormat = "General"
                .Cells(I, 2) = Format(DateValue(Day(.Cells(I, 2)) & "/" & Month(.Cells(I, 2)) & "/" & Year(.Cells(I, 2))), "dd/mm/yyyy")
 
            End If
 
            If IsDate(Cells(I, 3)) Then
 
                .Cells(I, 3).NumberFormat = "General"
                .Cells(I, 3) = Format(DateValue(Day(.Cells(I, 3)) & "/" & Month(.Cells(I, 3)) & "/" & Year(.Cells(I, 3))), "dd/mm/yyyy")
 
            End If
 
        Next I
 
        Ligne = .Cells(.Rows.Count, 1).End(xlUp).Row
 
        'Insere une ligne avant "Notes Nom Source"
        For I = Ligne To 1 Step -1
 
            If .Cells(I, 1) Like "Notes Nom source" Then .Rows(I).EntireRow.Insert Shift:=xlDown
 
        Next I
 
        .Columns(7).Delete Shift:=xlToLeft 'Supprime la colonne G "Message d'alarme
        .Columns(4).Delete Shift:=xlToLeft 'Supprime la colonne D "Message d'alarme
        .Columns(4).Delete Shift:=xlToLeft 'Supprime la colonne E "Message d'alarme
 
        'remplace les caracteres " / " par "    "
        .Cells.SpecialCells(xlCellTypeConstants).Replace " / ", "    "
 
        'inserer 2 colonnes vierges
        .Columns(2).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        .Columns(2).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
 
        Ligne = .Cells(.Rows.Count, 1).End(xlUp).Row
 
        Tblo_A = .Cells(1, 1).Resize(Ligne).Value
 
        For I = 1 To Ligne
 
            Tblo_B = Split(Tblo_A(I, 1), "    ") 'séparer les mots espacés de 4 espaces
 
            For j = 0 To UBound(Tblo_B) 'chaque mots de la phrase
 
                For K = j + 2 To UBound(Tblo_B) + 2
 
                    .Cells(I, K).Value = Tblo_B(j) 'ranger dans la cellule de droite le mot
 
                Next K
 
            Next j
 
        Next I
 
        .Columns("A:A").Delete Shift:=xlToLeft 'supprimer la 1ère colonne de données collés
        .Columns("B:B").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft 'efface les cellules vides de la colonne 2 en faisant un décallage vers la gauche
 
        Ligne = .Cells(.Rows.Count, 1).End(xlUp).Row
 
        For I = Ligne To 1 Step -1
 
            If .Cells(I, 1) Like "Notes Nom source" Then .Rows(I).EntireRow.Delete 'Supprime la ligne "Notes Nom Source"
 
        Next I
 
        .Columns("A:K").Columns.AutoFit 'ajuster la largeur des colonnes
 
    End With
 
    'rafraîchi
    Application.ScreenUpdating = True
 
End Sub

Hervé.

[010714]

Wahou, la vitesse d'execution du programme est hallucinante merci Hervé!

J'ai encore un soucis, je veux "trier" les temps qui sont dans le feuille 2 après avoir exécuté le programme.
Si le temps est superieur ou égal à 30 min il est automatiquement remplacé par 15min et si le temps est inferieur à 1 minute, la ligne est éffacée.
J'ai écrit le programme suivant mais cela ne fonctionne pas... :

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
Sub test()
 
ligne = cells(Rows.Count, 3).End(xlUp).Row
 
For i = 1 To ligne
Select Case Condition
 
Case Is <= "00:01:00"
Rows(i).EntireRow.Delete
 
Case Is >= "00:30:00"
    cells(i, 3).Value = "0:15:00"
    cells(i, 3).NumberFormat = "[h]:mm:ss;@"
 
End Select
 
Next i
 
End Sub

Pour les temps, j'ai par exemple :
0:00:38
0:19:20
0:17:28
0:00:00
0:04:16
0:00:00
0:35:45

Merci d'avance

[illight]

En faisant du pas à pas, tu peux remarquer qu'il ne rentre que dans la première condition, et jamais dans la seconde.

Il ne faut pas oublier que Excel considère, quelque soit le format de date, une date comme un nombre.

Dans un 2e temps, tu fais une boucle alors que tu supprime des lignes => à un moment, ton compteur va oublier des lignes, car lui va continuer de s'incrémenter, mais pas tes lignes.
Enfin, personnellement, j'aurai pas fait uns elect case, mais un simple IF :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
Sub test()
For i = 7 To 1 Step -1
If Cells(i, 1).Value <= TimeSerial(0, 1, 0) Then
    Rows(i).EntireRow.Delete
ElseIf Cells(i, 1).Value >= TimeSerial(0, 30, 0) Then
    Cells(i, 1).Value = TimeSerial(0, 15, 0)
    Cells(i, 1).NumberFormat = "[hh]:mm:ss;@"
End If
 
Next i
 
End Sub

[Theze]

Bonjour,

Tu parle de quelle feuille 2 la feuille "Exemple données Feuil2" ou la feuille "Feuile2" car dans la première il y a bien des heures mais à part pour la cellule A3 qui est bien au format date (02/07/2014 07:47:24) les autres valeurs de temps sont perdues dans le texte des cellules de la colonne A et qu'il va falloir extraire :

M6-PPE FOSSE SSTOILE 13-Depasti DEP281 29/06/2014 14:13:08 --- --- Contrôle - Alerte --- Fuite PE

et pour la feuille "Feuile2" je ne vois aucune valeur de temps ???
Dans le code ci-dessous, j'ai rajouté des lignes de code pour extraite les heures des lignes de la colonne A et elles sont mise en colonne F après, explique ce que tu veux faire si tant est que c'est bien de ces heures là que tu parle !
Je reposte le tout :

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
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
 
Sub Rapport_Mensuel()
 
    'variables objet
    Dim Feuille As Worksheet
    Dim Plage As Range
    Dim Cel As Range
 
    'variable pour la dernière ligne non vide
    Dim Ligne As Long
 
    'variable compteurs
    Dim I As Long
    Dim j As Long
    Dim K As Long
 
    'tableaux variants
    Dim Tblo_A
    Dim Tblo_B
 
    'gèle la mise à jour
    Application.ScreenUpdating = False
 
    'pour que la référence à la feuille visée soit bien claire...
    Set Feuille = Worksheets("Exemple données Feuil2")
 
    'fait référence à la feuille
    With Feuille
 
        On Error Resume Next
 
        'remplace les caracteres "," par "."
        .Cells.SpecialCells(xlCellTypeConstants).Replace ",", "."
 
        'Efface "Hiérarchie"
        .Cells.SpecialCells(xlCellTypeConstants).Replace "Hiérarchie / ", ""
 
        On Error GoTo 0
 
        Ligne = .Cells(.Rows.Count, 1).End(xlUp).Row
 
        Tblo_A = .Cells(4, 1).Resize(Ligne).Value 'A1 si on veut garder l'entête
 
        For K = 1 To Ligne
 
            Tblo_B = Split(Tblo_A(K, 1), "    ") 'séparer les mots espacés de 4 espaces
 
            For I = 0 To UBound(Tblo_B) 'chaque mots de la phrase
 
                For j = I + 2 To UBound(Tblo_B) + 2
 
                    .Cells(K, j).Value = Tblo_B(I) 'ranger dans la cellule de droite le mot
 
                Next j
 
            Next I
 
        Next K
 
        .Columns("A:A").Delete Shift:=xlToLeft 'supprimer la 1ère colonne de données collés
        .Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'efface toutes les lignes vides
        .Columns("A:K").HorizontalAlignment = xlCenter 'centrer le texte
        .Columns("D:E").NumberFormat = "General"
 
        Set Plage = .Range(.Cells(1, 1), .Cells(.Rows.Count, 3).End(xlUp))
 
        For Each Cel In Plage
 
           If Cel.Value = "---" Then Cel.Value = Cel.Offset(-1, 0).Value 'Si la cellule contient "---", elle prend la valeur de celle du dessus
 
        Next Cel
 
        'recherche la dernière cellule utilisée sur toutes les colonnes
        Ligne = .Cells.Find("*", .Range("A1"), xlFormulas, , 1, 2).Row
 
        For I = Ligne To 1 Step -1
 
            If .Cells(I, 6) Like "---" And .Cells(I, 8) Like "---" Then .Rows(I).Delete 'efface les lignes si il y a "---" dans les colonnes F et H
            If .Cells(I, 8) Like "OK" Or .Cells(I, 8) Like "Ensemble OK" Then .Rows(I).Delete  'efface les lignes si il y a "OK" ou "Ensemble OK" dans les colonnes F et H
            If .Cells(I, 1) Like " " Then .Rows(I).Delete 'efface les lignes contenant " " bug?
            If .Cells(I, 3) Like "Machine à l'arrêt" Then .Rows(I).Delete 'efface les lignes ou la colonne 3 contient "Machine à l'arrêt"
 
            'rajouter les differents cas qui ne sont pas en alerte...
 
        Next I
 
        Set Plage = .Range(.Cells(1, 6), .Cells(.Rows.Count, 6).End(xlUp))
 
        For Each Cel In Plage
 
           If Cel.Value = "---" Then Cel.Value = Cel.Offset(-1, 0).Value 'Si la cellule dans la colonne F contient "---", elle prend la valeur de celle du dessus
 
        Next Cel
 
        Ligne = .Cells(.Rows.Count, 3).End(xlUp).Row
 
        'Met sous la forme dd/mm/yyyy la date
        For I = 1 To Ligne
 
            If IsDate(Cells(I, 2)) Then
 
                .Cells(I, 8) = Split(Cells(I, 2), " ")(1) 'extraction de l'heure
                .Cells(I, 2).NumberFormat = "General"
                .Cells(I, 2) = Format(DateValue(Day(.Cells(I, 2)) & "/" & Month(.Cells(I, 2)) & "/" & Year(.Cells(I, 2))), "dd/mm/yyyy")
 
            End If
 
            If IsDate(Cells(I, 3)) Then
 
                .Cells(I, 9) = Split(Cells(I, 3), " ")(1) 'extraction de l'heure
                .Cells(I, 3).NumberFormat = "General"
                .Cells(I, 3) = Format(DateValue(Day(.Cells(I, 3)) & "/" & Month(.Cells(I, 3)) & "/" & Year(.Cells(I, 3))), "dd/mm/yyyy")
 
            End If
 
        Next I
 
        Ligne = .Cells(.Rows.Count, 1).End(xlUp).Row
 
        'Insere une ligne avant "Notes Nom Source"
        For I = Ligne To 1 Step -1
 
            If .Cells(I, 1) Like "Notes Nom source" Then .Rows(I).EntireRow.Insert Shift:=xlDown
 
        Next I
 
        .Columns(7).Delete Shift:=xlToLeft 'Supprime la colonne G "Message d'alarme
        .Columns(4).Delete Shift:=xlToLeft 'Supprime la colonne D "Message d'alarme
        .Columns(4).Delete Shift:=xlToLeft 'Supprime la colonne E "Message d'alarme
 
        'remplace les caracteres " / " par "    "
        .Cells.SpecialCells(xlCellTypeConstants).Replace " / ", "    "
 
        'inserer 2 colonnes vierges
        .Columns(2).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        .Columns(2).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
 
        Ligne = .Cells(.Rows.Count, 1).End(xlUp).Row
 
        Tblo_A = .Cells(1, 1).Resize(Ligne).Value
 
        For I = 1 To Ligne
 
            Tblo_B = Split(Tblo_A(I, 1), "    ") 'séparer les mots espacés de 4 espaces
 
            For j = 0 To UBound(Tblo_B) 'chaque mots de la phrase
 
                For K = j + 2 To UBound(Tblo_B) + 2
 
                    .Cells(I, K).Value = Tblo_B(j) 'ranger dans la cellule de droite le mot
 
                Next K
 
            Next j
 
        Next I
 
        .Columns("A:A").Delete Shift:=xlToLeft 'supprimer la 1ère colonne de données collés
        .Columns("B:B").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft 'efface les cellules vides de la colonne 2 en faisant un décallage vers la gauche
 
        Ligne = .Cells(.Rows.Count, 1).End(xlUp).Row
 
        For I = Ligne To 1 Step -1
 
            If .Cells(I, 1) Like "Notes Nom source" Then .Rows(I).EntireRow.Delete 'Supprime la ligne "Notes Nom Source"
 
        Next I
 
        .Columns("A:K").Columns.AutoFit 'ajuster la largeur des colonnes
 
        .Cells(1, 6).Value = "Heures"
    End With
 
    'rafraîchi
    Application.ScreenUpdating = True
 
End Sub

en l'attente de plus de précisions.

Hervé.

[010714]

Bonjour,
grace à vous j'ai réussi à resoudre presque tout mes problèmes :
Amélioration de la vitesse d'execution avec l'utilisation des tableaux, j'ai aussi réussi à faire fonctionner le rangement automatique et le tri avec les temps

Il ne me reste plus que ce problème :
J'ai un problème avec la mise en forme de cellules (tableau statistique pour chacune des machines), en effet, je souhaite remplacer une mise en forme automatique par un système de feu tricolor mais je n'arrive pas.
Je divise le contenu de ma cellule en C5 par le contenu de ma cellule en B5 et je compare par rapport a un "pourcentage".
Mon sytème de mise en forme automatique (qui fonctionne) est la suivante :

Cellule de couleur vert :
=SI((C5/B5)>=0,8;C5;FAUX)


Cellule de couleur orange :
=SI(ET((C5/B5)>0,5;(C5/B5)<=0,8);C5;FAUX)

Cellule de couleur rouge :
=SI((C5/B5)<=0,5;C5;FAUX)
(Ne fonctionne par si il y à "0" en C5

Je n'arrive pas à utiliser cette logique pour la mise en forme avec feu tricolore.
Merci

Marie

[Theze]

Bonjour,

Avec une fonction par exemple :

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
 
Function FEUXTRICOLORE(Cel1 As Range, Cel2 As Range) As Integer
 
    'pour une utilisation depuis une feuille Excel
    'Application.Volatile
 
    Select Case Cel1.Value / Cel2.Value
 
        Case Is >= 0.8
            FEUXTRICOLORE = 50
 
        Case Is > 0.5
            FEUXTRICOLORE = 46
 
        Case Is <= 0.5
            FEUXTRICOLORE = 3
 
    End Select
 
End Function
 
Sub Test()
 
    Range("D5").Interior.ColorIndex = FEUXTRICOLORE(Range("C5"), Range("B5"))
 
End Sub

Il y a une contradiction dans tes formules de MFC, "=SI((C5/B5)>=0,8;C5;FAUX)" et "=SI(ET((C5/B5)>0,5;(C5/B5)<=0,8);C5;FAUX)" le signe = est présent dans les deux alors qu'il ne ne être qu'une fois. Si c'est supérieur ou égal dans une, ça ne peut être qu'inférieur dans l'autre et vis et versa.

Hervé

[010714]

Bonjour,
J'ai essayée avec ton programme mais ce n'étais pas le résultat que je souhaite obtenir, je voudrais utiliser les traffic light icon
Pour le moment j'essaye de faire fonctionner le programme sur un cas seulement.

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
Sub Macro1()
Dim Division As Integer
 
Division = (Range("C5") / Range("B5"))
    Range("c5").Select
    Cells.FormatConditions.Delete
    Range("C5").FormatConditions.AddIconSetCondition
    Range("C5").FormatConditions(Range("C5").FormatConditions.Count).SetFirstPriority
    With Range("C5").FormatConditions(1)
        .ReverseOrder = False
        .ShowIconOnly = False
        .IconSet = ActiveWorkbook.IconSets(xl3Symbols)
    End With
    With Range("C5").FormatConditions(1).IconCriteria(2)
        .Type = xlConditionValueNumber
        .Value = 0.5'Si la valeur de C5 est superieur à 0.5 alors c'est orange, je voudrais que ce soit avec la valeur de Divison... tout en mettant en forme conditionnelle la cellule C5..
        .Operator = 5
    End With
    With Range("C5").FormatConditions(1).IconCriteria(3)
        .Type = xlConditionValueNumber
        .Value = 0.8'Si la valeur de C5 est superieur ou égale à 0.8 alors c'est vert, je voudrais que ce soit avec la valeur de Divison... tout en mettant en forme conditionnelle la cellule C5..
 
        .Operator = 7
    End With
 
End Sub

J'ai éssayé plusieurs méthodes mais je n'y parviens pas...

[Theze]

Bonjour,

Je testerai chez moi si j'ai le temps (Excel 2007) la propriété "IconSet" n'étant pas connue d'Excel 2003 (je ne sais même pas si elle est déjà connue d'Excel 2007 ?) :

Code :

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

1
2
 
.IconSet = ActiveWorkbook.IconSets(xl3Symbols)

Hervé.

[Marc-L]

Bonjour,

l'objet IconSets et la propriété IconSet existent depuis la version 2007 …

[Theze]

Bonsoir,

Après quelques tests, voici ce que je t'ai pondu. Pour appliquer cette MFC sur C5, il faut donner une valeur de référence à la propriété "Value". Les explications sont dans le code :

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
 
Sub MFC()
 
    'pour passer au vert, il faut que "C5" représente 80% et plus de "B5"
    'donc, la formule pour la propriété "Value" est "Range("B5").Value * 0.8"
 
    'pour passer au rouge, il faut que la valeur de "C5" soit inférieure à
    'la moitié des 80% de "B5" soit 40%
    'donc, la formule pour la propriété "Value" est "Range("B5").Value * 0.4"
 
    'entre ces deux valeurs, la couleur est orange
 
    'sur C5
    With Range("C5")
 
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
 
        With .FormatConditions
            .Delete
            .AddIconSetCondition
        End With
 
        With .FormatConditions(1)
 
            .IconSet = ActiveWorkbook.IconSets(xl3TrafficLights1)
 
            With .IconCriteria(2)
                .Type = xlConditionValueNumber
 
                'donne une valeur de référence plancher (40% de B5) pour passer au rouge
                .Value = Range("B5").Value * 0.4
 
                .Operator = 7
            End With
 
            With .IconCriteria(3)
                .Type = xlConditionValueNumber
 
                'donne une valeur de référence plafond (80% de B5) pour passer au vert
                .Value = Range("B5").Value * 0.8
                .Operator = 7
            End With
 
        End With
 
    End With
 
End Sub

Hervé.