Aide simplification programmes VBA

Version imprimable

Voir 40 message(s) de cette discussion en une page

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:

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

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:

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é.

Wahou, la vitesse d'execution du programme est hallucinante8O 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:

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

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:

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

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 :

Citation:

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:

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é.

16/07/2014, 15h46
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

Bonjour,

Avec une fonction par exemple :
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 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é

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:

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

18/07/2014, 10h12
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:

1 2 .IconSet = ActiveWorkbook.IconSets(xl3Symbols)
Hervé.
18/07/2014, 14h51
Marc-L

Bonjour,

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

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:

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é.

Voir 40 message(s) de cette discussion en une page