Aide simplification programmes VBA

Version imprimable

1 pièce(s) jointe(s)

Bonjour,
Je m'appelle Marie, j'ai 21 ans et j'aurais besoin de votre aide pour simplifier mon programme VBA.
Il fonctionne mais est long et bug souvent...
Je n’ai pas de compétences particulières en informatique c’est pourquoi je me tourne vers vous.
J'ai réussi à faire mon programme en m'inspirant sur différents forums et en adaptant au cas par cas des morceaux de programmes.

Je vous explique le fonctionnement de mon fichier Excel à travers mes 5 feuilles différentes :

Machine1 ; Machine2 ; Machine3 :
Sur ces feuilles ce trouvent les données des 3 machines (Machine 1, Machine2, Machine 3).
Pour chacune de ces machines il y a un tableau « statistique » et un tableau « récapitulatif ».
Le tableau statistique est composé de 4 colonnes : « Nom de la zone ; Objectif ; Réalisé ; Temps total ». La colonne « Réalisé » contient une mise en forme de la couleur des cellules en fonction de l’objectif : (vert>=80%) (>50% Orange <80%) & (<50% Rouge).
La colonne « réalisé » recherche en fonction du nom de la zone le nombre de fois que ce nom revient dans la colonne A de la feuille 3.
La colonne « Temps total » quant à elle fait la somme des temps de la feuille 3 du nom de la zone en question.
Le tableau « Récapitulatif » contient 6 colonnes « Exception Nom machine ; Nom du point ; Date heure ; Etat d’alarme ; Résultat contrôle ; Commentaire ».

Feuile2 :
Je colle dans la cellule A1 de cette feuille les données que vous pouvez trouver sur la feuille : « Exemple données Feuil2 » (souvent plus de 1000 lignes).
Le programme plante si il y a un « = » qui s’est glissé avant, je suis donc obligé de faire un recherche du caractère égal dans cette feuille et de le supprimer.
Sur cette feuille, une fois le programme exécuté, les informations sont rangées en 5 colonnes différentes.
Je sélectionne ensuite les données pour les coller manuellement à leur emplacement (tableau « récapitulatif ») en fonction de la machine sur la feuil1, je dois mettre manuellement la mise en forme.
J’aimerais pouvoir automatiser cette tâche en collant les données automatiquement sur la page de la machine spécifiée (Feuil1) avec une mise en forme automatique (bordure du tableau).

Feuile3 :
Je colle dans la cellule A1 de cette feuille les données que vous pouvez trouver sur la feuille : « Exemple données Feuil3 »
En exécutant le programme XX les données dont mise sous une forme spéciale « Nom de la zone ; Date ; Durée ; %réalisé »
Dans la Feuile1 au niveau du tableau statistique j’ai écrit une formule qui va rechercher pour chacun des noms de zone le nombre réalisé et le temps total passé.

J’aimerais que les mesures inférieure ou égale à 60% réalisé soit supprimés et également remplacer les temps de chaque zone supérieure à 45 minutes par 15 minutes.
J’aimerais aussi que le tableau « statistique » des feuilles des 3 machines ce remplisse automatiquement à partir du programme VBA.

Je vous joins mon fichier en .xlsx avec mon programme à la suite du message, j’ai essayé de détailler au maximum les opérations.
Dans l’attente de votre aide ;)

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
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
Sub Rapport_Mensuel()
virgule = Array(",")
Point = Array(".")
With Cells.SpecialCells(xlCellTypeConstants)
.Replace virgule, Point 'remplace les caracteres "," par "."
End With
 
'Efface "Hiérarchie"
origcaractere = Array("Hiérarchie / ")
newcaractere = Array("")
With Cells.SpecialCells(xlCellTypeConstants)
.Replace origcaractere, newcaractere
End With
 
n = [A1000].End(xlUp).Row
a = [A4].Resize(n).Value 'A1 si on veut garder l'entête
    Dim j As Integer
    Dim b As Variant, i As Long
For k = 1 To n
    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
Columns("A:A").Delete Shift:=xlToLeft 'supprimer la 1ère colonne de données collés
Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'efface toutes les lignes vides
Columns("A:K").HorizontalAlignment = xlCenter 'centrer le texte
Columns("D:E").NumberFormat = "General"
 
Dim z As Range
For Each z In Range("A:C", [A1000].End(xlUp))
   If z.Value = "---" Then z.Value = z.Offset(-1, 0).Value 'Si la cellule contient "---", elle prend la valeur de celle du dessus
Next z
 
 c = ActiveSheet.UsedRange.Rows.Count
    For d = c To 1 Step -1
        If Cells(d, 6) Like "---" And Cells(d, 8) Like "---" Then Rows(d).Delete 'efface les lignes si il y a "---" dans les colonnes F et H
        If Cells(d, 8) Like "OK" Then Rows(d).Delete 'efface les lignes si il y a "OK" dans les colonnes F et H
        If Cells(d, 8) Like "Ensemble OK" Then Rows(d).Delete 'efface les lignes si il y a "Ensemble OK" dans les colonnes F et H
        If Cells(d, 1) Like " " Then Rows(d).Delete 'efface les lignes contenant " " bug?
        If Cells(d, 3) Like "Machine à l'arrêt" Then Rows(d).Delete 'efface les lignes ou la colonne 3 contient "Machine à l'arrêt"
'rajouter les differents cas qui ne sont pas en alerte
   Next d
 
Dim y As Range
For Each y In Range("F1", [F1000].End(xlUp))
   If y.Value = "---" Then y.Value = y.Offset(-1, 0).Value 'Si la cellule dans la colonne F contient "---", elle prend la valeur de celle du dessus
Next y
 
'Met sous la forme dd/mm/yyyy la date
Dim ic As Long
Dim vc As Double
Dim jc As Integer, mc As Integer, ac As Integer
Dim sJc As String, sMc As String
Dim sc As String
 
    For ic = 1 To 1000
        If IsDate(Cells(ic, 3)) Then
            vc = CDbl(CDate(Cells(ic, 3)))
            jc = Day(vc)
            mc = Month(vc)
            ac = Year(vc)
 
            Select Case jc
                Case 1 To 9: sJc = "0" & jc
                Case Else: sJc = jc
            End Select
 
            Select Case mc
                Case 1 To 9: sMc = "0" & mc
                Case Else: sMc = mc
            End Select
 
            sc = sJc & "/" & sMc & "/" & ac
 
            Cells(ic, 3).NumberFormat = "General"
            Cells(ic, 3) = Format(sc, "dd/mm/yyyy")
        End If
    Next ic
 
'Pour les dates des notes, modifier "2" par le numéro de colonnes ou elle sera apres découpage
Dim ib As Long
Dim vb As Double
Dim jb As Integer, mb As Integer, ab As Integer
Dim sJb As String, sMb As String
Dim sb As String
 
    For ib = 1 To 1000
        If IsDate(Cells(ib, 2)) Then
            vb = CDbl(CDate(Cells(ib, 2)))
            jb = Day(vb)
            mb = Month(vb)
            ab = Year(vb)
 
            Select Case jb
                Case 1 To 9: sJb = "0" & jb
                Case Else: sJb = jb
            End Select
 
            Select Case mb
                Case 1 To 9: sMb = "0" & mb
                Case Else: sMb = mb
            End Select
 
            sb = sJb & "/" & sMb & "/" & ab
 
            Cells(ib, 2).NumberFormat = "General"
            Cells(ib, 2) = Format(sb, "dd/mm/yyyy")
        End If
    Next ib
 
'Ajoute une ligne devant "Notes Nom source"
cc = ActiveSheet.UsedRange.Rows.Count
    For dc = cc To 1 Step -1
        If Cells(dc, 1) Like "Notes Nom source" Then Rows(dc).EntireRow.Insert Shift:=xlDown 'Insere une ligne avant "Notes Nom Source"
Next dc
 
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
 
origString = Array(" / ")
newString = Array("    ")
With Cells.SpecialCells(xlCellTypeConstants)
.Replace origString, newString 'remplace les caracteres " / " par "    "
End With
 
'inserer 2 colonnes vierges
Columns(2).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns(2).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
 
ni = [A100].End(xlUp).Row
ai = [A1].Resize(ni).Value
    Dim ji As Integer
    Dim bi As Variant, ii As Long
For ki = 1 To ni
    bi = Split(ai(ki, 1), "    ") 'séparer les mots espacés de 4 espaces
         For ii = 0 To UBound(bi) 'chaque mots de la phrase
            For ji = ii + 2 To UBound(bi) + 2
    Cells(ki, ji).Value = bi(ii) 'ranger dans la cellule de droite le mot
            Next ji
        Next ii
Next ki
 
Columns("A:A").Delete Shift:=xlToLeft 'supprimer la 1ère colonne de données collés
Columns(2).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft 'efface les cellules vides de la colonne 2 en faisant un décallage vers la gauche
 
cf = ActiveSheet.UsedRange.Rows.Count
    For df = cf To 1 Step -1
        If Cells(df, 1) Like "Notes Nom source" Then Rows(df).EntireRow.Delete 'Supprime la ligne "Notes Nom Source"
Next df
 
 
Columns("A:K").Columns.AutoFit 'ajuster la largeur des colonnes
 
End Sub
 
Sub Suivi_Rondes()
virgule = Array(",")
Point = Array(".")
With Cells.SpecialCells(xlCellTypeConstants)
.Replace virgule, Point 'remplace les caracteres "," par "."
End With
 
n = [A1000].End(xlUp).Row
a = [A5].Resize(n).Value 'A1 si on veut garder l'entête
    Dim j As Integer
    Dim b As Variant, i As Long
For k = 1 To n
    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
 
Columns("A:A").Delete Shift:=xlToLeft 'supprimer la 1ère colonne de données collés
Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'efface toutes les lignes vides
Columns("A:K").HorizontalAlignment = xlCenter 'centrer le texte
 
'Met sous la forme dd/mm/yyyy la date
Dim ii As Long
Dim v As Double
Dim jj As Integer, m As Integer, aa As Integer
Dim sJ As String, sM As String
Dim s As String
 
    For ii = 1 To 1000
        If IsDate(Cells(ii, 2)) Then
            v = CDbl(CDate(Cells(ii, 2)))
            jj = Day(v)
            m = Month(v)
            aa = Year(v)
 
            Select Case j
                Case 1 To 9: sJ = "0" & jj
                Case Else: sJ = jj
            End Select
 
            Select Case m
                Case 1 To 9: sM = "0" & m
                Case Else: sM = m
            End Select
 
            s = sJ & "/" & sM & "/" & aa
 
            Cells(ii, 2).NumberFormat = "General"
            Cells(ii, 2) = Format(s, "dd/mm/yyyy")
        End If
    Next ii
 
Columns(4).NumberFormat = "General"
Columns("A:K").Columns.AutoFit 'ajuster la largeur des colonnes
Dim z As Range
For Each z In Range("A:C", [A1000].End(xlUp))
   If z.Value = "---" Then z.Value = z.Offset(-1, 0).Value 'Si la cellule contient "---", elle prend la valeur de celle du dessus
Next z
 
c = Array("h")
cc = Array("")
'With Cells.SpecialCells(xlCellTypeConstants)
With Columns(3)
.Replace c, cc
'End With
d = Array("m")
dd = Array("")
'With Cells.SpecialCells(xlCellTypeConstants)
.Replace d, dd
'End With
e = Array("s")
ee = Array("")
'With Cells.SpecialCells(xlCellTypeConstants)
.Replace e, ee
'End With
f = Array(": ")
ff = Array(":")
'With Cells.SpecialCells(xlCellTypeConstants)
.Replace f, ff
End With
 
Columns(3).NumberFormat = "[h]:mm:ss;@"
 
End Sub

02/07/2014, 09h14
illight

Si tu pouvais mettre les balise CODE (voir ma signature) dans ton message sur ton code, ça serait déjà plus lisible :)

Tu as essayé de faire du pas à pas pouvoir où ton programme prenait du temps ?

Qu'entends-tu par :

Citation:

Le programme plante si il y a un « = » qui s’est glissé avant, je suis donc obligé de faire un recherche du caractère égal dans cette feuille et de le supprimer.

Il plante ? tu as un message d'erreur ? quel type ? qu'est-ce qu'il dit ?

"Il plante" c'est pas très explicite :mrgreen:
02/07/2014, 09h21
Tooth

Bonjour Marie,

Pour faciliter la lecture de ton code et ainsi améliorer les chances de réponse, peux tu mettre les balises de "Code" , c'est le petit symbole # dans la barre de mise en forme.

Pour ce qui est de la tâche automatique en feuil2, y a-t-il des critères de copie pour savoir où les données doivent aller se coller ? Où les données se copient pour toutes les feuilles Machine ?

Avec qu'elles données doit se remplir le tableau statistiques de chaque Machine ?

Cordialement,

Thomas

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
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
Sub Rapport_Mensuel()
virgule = Array(",")
Point = Array(".")
With Cells.SpecialCells(xlCellTypeConstants)
.Replace virgule, Point 'remplace les caracteres "," par "."
End With
 
'Efface "Hiérarchie"
origcaractere = Array("Hiérarchie / ")
newcaractere = Array("")
With Cells.SpecialCells(xlCellTypeConstants)
.Replace origcaractere, newcaractere
End With
 
n = [A1000].End(xlUp).Row
a = [A4].Resize(n).Value 'A1 si on veut garder l'entête
    Dim j As Integer
    Dim b As Variant, i As Long
For k = 1 To n
    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
Columns("A:A").Delete Shift:=xlToLeft 'supprimer la 1ère colonne de données collés
Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'efface toutes les lignes vides
Columns("A:K").HorizontalAlignment = xlCenter 'centrer le texte
Columns("D:E").NumberFormat = "General"
 
Dim z As Range
For Each z In Range("A:C", [A1000].End(xlUp))
   If z.Value = "---" Then z.Value = z.Offset(-1, 0).Value 'Si la cellule contient "---", elle prend la valeur de celle du dessus
Next z
 
 c = ActiveSheet.UsedRange.Rows.Count
    For d = c To 1 Step -1
        If Cells(d, 6) Like "---" And Cells(d, 8) Like "---" Then Rows(d).Delete 'efface les lignes si il y a "---" dans les colonnes F et H
        If Cells(d, 8) Like "OK" Then Rows(d).Delete 'efface les lignes si il y a "OK" dans les colonnes F et H
        If Cells(d, 8) Like "Ensemble OK" Then Rows(d).Delete 'efface les lignes si il y a "Ensemble OK" dans les colonnes F et H
        If Cells(d, 1) Like " " Then Rows(d).Delete 'efface les lignes contenant " " bug?
        If Cells(d, 3) Like "Machine à l'arrêt" Then Rows(d).Delete 'efface les lignes ou la colonne 3 contient "Machine à l'arrêt"
'rajouter les differents cas qui ne sont pas en alerte
   Next d
 
Dim y As Range
For Each y In Range("F1", [F1000].End(xlUp))
   If y.Value = "---" Then y.Value = y.Offset(-1, 0).Value 'Si la cellule dans la colonne F contient "---", elle prend la valeur de celle du dessus
Next y
 
'Met sous la forme dd/mm/yyyy la date
Dim ic As Long
Dim vc As Double
Dim jc As Integer, mc As Integer, ac As Integer
Dim sJc As String, sMc As String
Dim sc As String
 
    For ic = 1 To 1000
        If IsDate(Cells(ic, 3)) Then
            vc = CDbl(CDate(Cells(ic, 3)))
            jc = Day(vc)
            mc = Month(vc)
            ac = Year(vc)
 
            Select Case jc
                Case 1 To 9: sJc = "0" & jc
                Case Else: sJc = jc
            End Select
 
            Select Case mc
                Case 1 To 9: sMc = "0" & mc
                Case Else: sMc = mc
            End Select
 
            sc = sJc & "/" & sMc & "/" & ac
 
            Cells(ic, 3).NumberFormat = "General"
            Cells(ic, 3) = Format(sc, "dd/mm/yyyy")
        End If
    Next ic
 
'Pour les dates des notes, modifier "2" par le numéro de colonnes ou elle sera apres découpage
Dim ib As Long
Dim vb As Double
Dim jb As Integer, mb As Integer, ab As Integer
Dim sJb As String, sMb As String
Dim sb As String
 
    For ib = 1 To 1000
        If IsDate(Cells(ib, 2)) Then
            vb = CDbl(CDate(Cells(ib, 2)))
            jb = Day(vb)
            mb = Month(vb)
            ab = Year(vb)
 
            Select Case jb
                Case 1 To 9: sJb = "0" & jb
                Case Else: sJb = jb
            End Select
 
            Select Case mb
                Case 1 To 9: sMb = "0" & mb
                Case Else: sMb = mb
            End Select
 
            sb = sJb & "/" & sMb & "/" & ab
 
            Cells(ib, 2).NumberFormat = "General"
            Cells(ib, 2) = Format(sb, "dd/mm/yyyy")
        End If
    Next ib
 
'Ajoute une ligne devant "Notes Nom source"
cc = ActiveSheet.UsedRange.Rows.Count
    For dc = cc To 1 Step -1
        If Cells(dc, 1) Like "Notes Nom source" Then Rows(dc).EntireRow.Insert Shift:=xlDown 'Insere une ligne avant "Notes Nom Source"
Next dc
 
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
 
origString = Array(" / ")
newString = Array("    ")
With Cells.SpecialCells(xlCellTypeConstants)
.Replace origString, newString 'remplace les caracteres " / " par "    "
End With
 
'inserer 2 colonnes vierges
Columns(2).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns(2).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
 
ni = [A100].End(xlUp).Row
ai = [A1].Resize(ni).Value
    Dim ji As Integer
    Dim bi As Variant, ii As Long
For ki = 1 To ni
    bi = Split(ai(ki, 1), "    ") 'séparer les mots espacés de 4 espaces
         For ii = 0 To UBound(bi) 'chaque mots de la phrase
            For ji = ii + 2 To UBound(bi) + 2
    Cells(ki, ji).Value = bi(ii) 'ranger dans la cellule de droite le mot
            Next ji
        Next ii
Next ki
 
Columns("A:A").Delete Shift:=xlToLeft 'supprimer la 1ère colonne de données collés
Columns(2).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft 'efface les cellules vides de la colonne 2 en faisant un décallage vers la gauche
 
cf = ActiveSheet.UsedRange.Rows.Count
    For df = cf To 1 Step -1
        If Cells(df, 1) Like "Notes Nom source" Then Rows(df).EntireRow.Delete 'Supprime la ligne "Notes Nom Source"
Next df
 
 
Columns("A:K").Columns.AutoFit 'ajuster la largeur des colonnes
 
End Sub
 
Sub Suivi_Rondes()
virgule = Array(",")
Point = Array(".")
With Cells.SpecialCells(xlCellTypeConstants)
.Replace virgule, Point 'remplace les caracteres "," par "."
End With
 
n = [A1000].End(xlUp).Row
a = [A5].Resize(n).Value 'A1 si on veut garder l'entête
    Dim j As Integer
    Dim b As Variant, i As Long
For k = 1 To n
    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
 
Columns("A:A").Delete Shift:=xlToLeft 'supprimer la 1ère colonne de données collés
Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'efface toutes les lignes vides
Columns("A:K").HorizontalAlignment = xlCenter 'centrer le texte
 
'Met sous la forme dd/mm/yyyy la date
Dim ii As Long
Dim v As Double
Dim jj As Integer, m As Integer, aa As Integer
Dim sJ As String, sM As String
Dim s As String
 
    For ii = 1 To 1000
        If IsDate(Cells(ii, 2)) Then
            v = CDbl(CDate(Cells(ii, 2)))
            jj = Day(v)
            m = Month(v)
            aa = Year(v)
 
            Select Case j
                Case 1 To 9: sJ = "0" & jj
                Case Else: sJ = jj
            End Select
 
            Select Case m
                Case 1 To 9: sM = "0" & m
                Case Else: sM = m
            End Select
 
            s = sJ & "/" & sM & "/" & aa
 
            Cells(ii, 2).NumberFormat = "General"
            Cells(ii, 2) = Format(s, "dd/mm/yyyy")
        End If
    Next ii
 
Columns(4).NumberFormat = "General"
Columns("A:K").Columns.AutoFit 'ajuster la largeur des colonnes
Dim z As Range
For Each z In Range("A:C", [A1000].End(xlUp))
   If z.Value = "---" Then z.Value = z.Offset(-1, 0).Value 'Si la cellule contient "---", elle prend la valeur de celle du dessus
Next z
 
c = Array("h")
cc = Array("")
'With Cells.SpecialCells(xlCellTypeConstants)
With Columns(3)
.Replace c, cc
'End With
d = Array("m")
dd = Array("")
'With Cells.SpecialCells(xlCellTypeConstants)
.Replace d, dd
'End With
e = Array("s")
ee = Array("")
'With Cells.SpecialCells(xlCellTypeConstants)
.Replace e, ee
'End With
f = Array(": ")
ff = Array(":")
'With Cells.SpecialCells(xlCellTypeConstants)
.Replace f, ff
End With
 
Columns(3).NumberFormat = "[h]:mm:ss;@"
 
End Sub

Effectivement c'est plus clair de cette manière :)
Je lors de l'exécution du programme, il y a un passage ou s'affiche "pas de réponse" sur Excel puis ça marche après... Je pense que je fait plusieurs fois les mêmes étapes dans mon programme, c'est peut être pour cela qu'il a du mal.
Pour ce qui est du caractère "=", lors de l'execution du programme j'ai un message d'erreur de type : "incompatibilité de type", dans la cellule qui contient le caractère "=" est affiché "#NOM?"

02/07/2014, 09h37
010714

@ Tooth

Bonjour Thomas,
Pour ce qui est de la feuille 2, les données contenant les caractères M6 dans la 1ère colonne doivent ce copier automatiquement sur la feuille de la machine 1, M12 pour la machine 2 et RAFF pour la machine 3. Une fois copié, j'aimerais qu'il n'y ai plus de lien avec la feuille.
Le tableau statistique ce rempli automatiquement a partir de la feuille 3, pour chacune des machines, j'ai écrit à la main le nom des zones (il n'y a pas d'importance, elle ne sont pas censé changer). J'ai écrit 2 formules pour aller chercher l'objectif réalisé dans la feuille 3 à partir du nom de la zone.
Le temps est également recherché à partir de la feuille 3.

Merci pour vos réponses rapide :)

Voila un code que je viens d'écrire, je ne pense pas qu'il marche du premier coup, il doit surement y avoir des erreurs de syntaxe ou autre puisque je ne peux pas le tester mais ça peut te faire une base de travail pour ton problème avec la feuille 2. Pour ce qui est de la mise en forme avec les bordures, il faut passer par l'enregistreur de macro et analyser le code généré.

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
 
 
Dim plage as Range
Dim cel as Range
Dim compteurBoucle As Integer
Dim nbLigne As Integer
 
 With Worksheets("Feuile2")
        nbLigne = .Range("D" & .Rows.Count).End(xlUp).Row
End With
 
Set plage = Worksheets("Feuile2").Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
 
do while compteurBoucle <= nbLigne
 
For each cel in Plage
 
         pos = Instr(Cel.Value,"-")
 
         texte = Left(Cel.valie, pos-1)
 
         Select case Texte
 
         Case "M6"
 
         Cells(compteurBoucle,1).EntireRow.Copy Worksheets("Machine1").Range("F1").End(xlDown).Offset(1, 0))
 
         Case "M12"
 
         Cells(compteurBoucle,1).EntireRow.Copy Worksheets("Machine2").Range("F1").End(xlDown).Offset(1, 0))
 
         Case "RAFF"
 
         Cells(compteurBoucle,1).EntireRow.Copy Worksheets("Machine3").Range("F1").End(xlDown).Offset(1, 0))
 
        end select
 
next cell
 
loop

J'ai modifié le programme mais il apparait un erreur d'execution 1004 "erreur définie par l'application ou par l'objet"
Je n'arrive pas a joindre mon fichier Excel prenant en charge les macros...
Je l'ai mis a disposition en format classique dans mon premier message.

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
Sub Rangement()
Dim plage As Range
Dim cel As Range
Dim compteurBoucle As Integer
Dim nbLigne As Integer
 
 With Worksheets("Feuile2")
        nbLigne = .Range("D" & .Rows.Count).End(xlUp).Row
End With
 
Set plage = Worksheets("Feuile2").Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
 
Do While compteurBoucle <= nbLigne
 
For Each cel In plage
 
         pos = InStr(cel.Value, "-")
 
         Texte = Left(cel.valie, pos - 1)
 
         Select Case Texte
 
         Case "M6"
 
         Cells(compteurBoucle, 1).EntireRow.Copy Worksheets("Machine1").Range("F1").End(xlDown).Offset(1, 0)
 
         Case "M12"
 
         Cells(compteurBoucle, 1).EntireRow.Copy Worksheets("Machine2").Range("F1").End(xlDown).Offset(1, 0)
 
         Case "RAFF"
 
         Cells(compteurBoucle, 1).EntireRow.Copy Worksheets("Machine3").Range("F1").End(xlDown).Offset(1, 0)
 
        End Select
 
Next cel
 
Loop
End Sub

02/07/2014, 10h49
Tooth

Sur quelle ligne l'erreur apparait ?

Fais un déroulement en pas à pas détaillé pour identifier l'erreur.

Je vois déjà au moins deux oublis de ma part, j'ai oublié de déclarer "Pos" en integer et "Texte" en String

En pas a pas détaillé, l'erreur s'affiche après la ligne 14 dans ce programme après avoir déclaré "posé et "texte"

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
Sub Rangement()
Dim plage As Range
Dim cel As Range
Dim compteurBoucle As Integer
Dim nbLigne As Integer
Dim pos As Integer
Dim Texte As String
 
 
 With Worksheets("Feuile2")
        nbLigne = .Range("D" & .Rows.Count).End(xlUp).Row
End With
 
Set plage = Worksheets("Feuile2").Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
 
Do While compteurBoucle <= nbLigne
 
For Each cel In plage
 
         pos = InStr(cel.Value, "-")
 
         Texte = Left(cel.valie, pos - 1)
 
         Select Case Texte
 
         Case "M6"
 
         Cells(compteurBoucle, 1).EntireRow.Copy Worksheets("Machine1").Range("F1").End(xlDown).Offset(1, 0)
 
         Case "M12"
 
         Cells(compteurBoucle, 1).EntireRow.Copy Worksheets("Machine2").Range("F1").End(xlDown).Offset(1, 0)
 
         Case "RAFF"
 
         Cells(compteurBoucle, 1).EntireRow.Copy Worksheets("Machine3").Range("F1").End(xlDown).Offset(1, 0)
 
        End Select
 
Next cel
 
Loop
End Sub

03/07/2014, 08h36
Tooth

Ce qui serait intéressant ce serai d'avoir ton fichier et qui prenne en charge les macros, là impossible pour moi de tester et de tenter de corriger l'erreur. Je me demande si ce n'est pas parce que tu as une ligne vide dans ton fichier et le XlUP le ferait planté.
03/07/2014, 08h53
010714

Bonjour,
Effectivement la ligne vide posait problème, maintenant j'arrive à la ligne 22 avant que l'erreur intervienne : "erreur d'execution 438, propriété ou méthode non gérée par cet objet.
Le problème c'est que j'ai besoin de cette ligne vide pour séparer en deux parties les données qui sont differentes dans le tableau.
Pour ce qui est du fichier macro, je n'arrive pas à le mettre en ligne, une erreur "fichier non valide" apparait quand j'essaye de le joindre au message...
Si tu prend le fichier sans macro et que tu colle l'ensemble des programmes dans la partie VBA cela ne fonctionne pas?
03/07/2014, 09h20
illight

Sur la ligne 22 :

Code:

Texte = Left(cel.valie, pos - 1)

il y a une faute de frappe => c'est ce.value ;)

Code:

Texte = Left(cel.valUe, pos - 1)
03/07/2014, 14h40
010714

Merci pour ta réponse illight, maintenant j'ai une erreur d'execution 5 : argument ou appel de procédure incorrècte...

Bon, je viens de réussir à résoudre l'erreure 5, l'erreur provenait du fait que la cellule A1 ne commencait pas par M6-xxx, j'ai donc effacé cette ligne.
Mon programme arrive jusqu'a la ligne 28 ou s'affiche erreur d'execution 1004, définie par l'application ou par l'objet.
03/07/2014, 16h29
illight

Code:

Cells(compteurBoucle, 1).EntireRow.Copy Worksheets("Machine1").Range("F1").End(xlDown).Offset(1, 0)

Ta variable compteurBoucle n'est jamais initialisée (ou alors j'ai pas les yeux en face des trous), du coup, elle vaut 0 au début.

Cells(0,1) n'existe pas :mrgreen:

par ailleurs tu fais une boucle :

Code:

Do While compteurBoucle <= nbLigne

Sauf que aucun de tes 2 critères ne s'incrémente => tu vas te retrouver avec une boucle infinie :?

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
Sub Rangement()
Dim plage As Range
Dim cel As Range
Dim compteurBoucle As Integer
Dim nbLigne As Integer
Dim pos As Integer
Dim Texte As String
 
 
 With Worksheets("Feuile2")
        nbLigne = .Range("D" & .Rows.Count).End(xlUp).Row
End With
 
Set plage = Worksheets("Feuile2").Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
 
compteurBoucle = 1'J'ai initialisé compteurBoucle à 1?
 
Do While compteurBoucle <= nbLigne
 
For Each cel In plage
 
         pos = InStr(cel.Value, "-")
 
         Texte = Left(cel.Value, pos - 1)
 
         Select Case Texte
 
         Case "M6"
 
         Cells(compteurBoucle, 1).EntireRow.Copy Worksheets("Machine1").Range("F1").End(xlDown).Offset(1, 0)
 
         Case "M12"
 
         Cells(compteurBoucle, 1).EntireRow.Copy Worksheets("Machine2").Range("F1").End(xlDown).Offset(1, 0)
 
         Case "RAFF"
 
         Cells(compteurBoucle, 1).EntireRow.Copy Worksheets("Machine3").Range("F1").End(xlDown).Offset(1, 0)
 
        End Select
 compteurBoucle = compteurBoucle + 1'j'ai rajouté l'incrémentation de compteurBoucle
Next cel
 
Loop
End Sub

J'ai toujours mon erreur 1004

Le programme ne fonctionne toujours pas alors j'ai essayée (et réussi) a gagner un peut de temps sur le reste de mon programme qui fonctionne en modifiant les plages d'execution mais pour le programme ci dessous je n'y arrive pas :

Code:

1
2
3
4
Dim z As Range
For Each z In Range("A:C", [A1000].End(xlUp))
   If z.Value = "---" Then z.Value = z.Offset(-1, 0).Value 'Si la cellule contient "---", elle prend la valeur de celle du dessus
Next z

Traduit en français je voudrais que pour chaque cellule comprise dans la plage (colonne A à colonne C jusqu'a la dernière ligne non vide).
Je voudrais que si la cellule contient --- elle soit remplacée par la valeure de la cellule du dessus.
Il faut que je commence par le haut de la feuille.

04/07/2014, 10h07
illight
Pour l'erreur 1004, j'arrive pas à comprendre d'où vient l'erreur :weird: je cherche encore. C'est bien toujours sur la ligne 30 ?

Je ne maitrise pas totalement les offSet je t'avouerai (peut-être que quelqu'un pourra t'aiguiller). Par contre, je vois peut-être un souci que tu pourrais rencontrer :
Code:

1 2 3 For Each z In Range("A:C", [A1000].End(xlUp)) If z.Value = "---" Then z.Value = z.Offset(-1, 0).Value 'Si la cellule contient "---", elle prend la valeur de celle du dessus Next z
Dans ce code ici, tu prend la valeur du dessus. Le problème est que si tu es sur la première ligne (ligne 1 donc), et que tu essaye de prendre la valeur au-dessus, je pense que le système ne va pas comprendre, car la ligne 0 n'existe pas. Ce que je ne sais pas,c 'est comment se comporte le OffSet si la ligne est inexistante. Sort-il une erreur ? je sais pas :? bon oui ça te sort une erreur 1004 (je viens de tester). Donc tu risques d'avoir un problème à ce niveau-là.

Tiens ne serait-ce pas ça ton problème de ta copy sur ta ligne 30 ? Tu fais aussi un offSet, si ça se trouve, tu es tout en haut, et du coup, ça ne marche pas ?

En espérant t'avoir aiguillé :?
04/07/2014, 10h12
Mr Poulpe

Bonjour,

Sauf erreur de ma part, ta boucle parcourt l'ensemble des 3 colonnes A:C (plus de 3 millions de cellules).

Je pense qu'il faudrait redéfinir ta plage, avec quelque chose du type range("A2:C2",range("A2:C2").end(xldown)) (en supposant que tu n'aies pas de cellule vide dans ta plage).

Poulpe
04/07/2014, 10h29
010714

Super, Merci Mr Poulpe, je me doutais que c'était un problème de ce style mais je n'arrivais pas du tout a écrire la plage de données:D

Bonjour à tous,
J'ai réussie à améliorer la vitesse d'execution de mes programmes, je vous les joints :

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
Sub Suivi_Rondes()
 
 
'Mettre les colonnes A à G en fromat standard :
Columns("A:G").NumberFormat = "General"
 
'Remplacer les caractères "," par "." :
virgule = Array(",")
Point = Array(".")
With Cells.SpecialCells(xlCellTypeConstants)
.Replace virgule, Point
End With
 
 
'Séparer la chaine de mots dans plusieurs colonnes :
With Worksheets("Suivi Rondes mensuel")
    nbLigne = .Range("A" & .Rows.Count).End(xlUp).Row
End With
a = [A5].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
 
 
'supprimer la 1ère colonne de données collés
Columns("A:A").Delete Shift:=xlToLeft
 
 
'efface toutes les lignes vides
Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 
 
'centrer le texte
Columns("A:K").HorizontalAlignment = xlCenter
 
 
'Met sous la forme dd/mm/yyyy la date
Dim ii As Long
Dim v As Double
Dim jj As Integer, m As Integer, aa As Integer
Dim sJ As String, sM As String
Dim s As String
 
    For ii = 1 To nbLigne
        If IsDate(Cells(ii, 2)) Then
            v = CDbl(CDate(Cells(ii, 2)))
            jj = Day(v)
            m = Month(v)
            aa = Year(v)
 
            Select Case j
                Case 1 To 9: sJ = "0" & jj
                Case Else: sJ = jj
            End Select
 
            Select Case m
                Case 1 To 9: sM = "0" & m
                Case Else: sM = m
            End Select
 
            s = sJ & "/" & sM & "/" & aa
 
            Cells(ii, 2).NumberFormat = "General"
            Cells(ii, 2) = Format(s, "dd/mm/yyyy")
        End If
    Next ii
 
 
'Mise en forme de la colonne D :
Columns(4).NumberFormat = "General"
 
 
'ajuster la largeur des colonnes de A à K :
Columns("A:K").Columns.AutoFit
 
 
'Si la cellule contient "---", elle prend la valeur de celle du dessus :
Dim z As Range
For Each z In Range("A1:C1", Range("A1:C1").End(xlDown)) 'Pour la plage des cellules de la colonne A à la colonne C jusqu'a la dernière ligne non vide
   If z.Value = "---" Then z.Value = z.Offset(-1, 0).Value 'Prendre la valeur de la cellule du dessus
Next z
 
 
'Modifier l'heure de la colonne 3 pour passer de XXh: XXm: XXs à XX:XX:XX :
c = Array("h")
cc = Array("")
d = Array("m")
dd = Array("")
e = Array("s")
ee = Array("")
f = Array(": ")
ff = Array(":")
 
With Columns(3)
.Replace c, cc
.Replace d, dd
.Replace e, ee
.Replace f, ff
End With
 
 
 
'Mise en forme de la colonne C au format "Heure" HH:MM:SS :
Columns(3).NumberFormat = "[h]:mm:ss;@"
 
 
End Sub

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
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
Sub Rapport_Mensuel()
 
 
'Pour que le programme fonctionne il faut que le rapport mensuel soit composé des colonnes suivantes : Nom machine; Nom du POINT; Date/heure; Dernière valeur; Valeur précédente; Etat d'alarme; Message d'alarme; Résultat contrôle
 
 
'Remplacer les caractères "," par "." :
virgule = Array(",")
Point = Array(".")
With Cells.SpecialCells(xlCellTypeConstants)
.Replace virgule, Point
End With
 
 
'Effacer le caractère "Hiérarchie" :
origcaractere = Array("Hiérarchie / ")
newcaractere = Array("")
With Cells.SpecialCells(xlCellTypeConstants)
.Replace origcaractere, newcaractere
End With
 
 
'Séparer la chaine de mots dans plusieurs colonnes :
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
 
 
'Supprimer la 1ère colonne "données collés à partir de SKF" :
Columns("A:A").Delete Shift:=xlToLeft
 
 
'Effacer toutes les lignes vides :
Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 
 
'Centrer le texte des colonnes A à K :
Columns("A:K").HorizontalAlignment = xlCenter
 
 
'Appliquer un format "Standard" pour les colonnes D à E :
Columns("D:E").NumberFormat = "General"
 
 
'Si la cellule contient "---", elle prend la valeur de celle du dessus (Pour les colonnes A à C) :
Dim z As Range
For Each z In Range("A2:C2", Range("A2:C2").End(xlDown))
   If z.Value = "---" Then z.Value = z.Offset(-1, 0).Value
Next z
 
 
'Supprimer les lignes contenant des informations non importante :
 c = ActiveSheet.UsedRange.Rows.Count
    For d = c To 1 Step -1
        If Cells(d, 6) Like "---" And Cells(d, 8) Like "---" Then Rows(d).Delete 'efface les lignes si il y a "---" dans les colonnes F et H
        If Cells(d, 8) Like "OK" Then Rows(d).Delete 'efface les lignes si il y a "OK" dans les colonnes F et H
        If Cells(d, 8) Like "Ensemble OK" Then Rows(d).Delete 'efface les lignes si il y a "Ensemble OK" dans les colonnes F et H
        If Cells(d, 1) Like " " Then Rows(d).Delete 'efface les lignes contenant " " bug?
        If Cells(d, 3) Like "Machine à l'arrêt" Then Rows(d).Delete 'efface les lignes ou la colonne 3 contient "Machine à l'arrêt"
   Next d
 
 
'Si la cellule contient "---", elle prend la valeur de celle du dessus (Pour la colonne F) :
Dim y As Range
For Each y In Range("F1", Range("F1").End(xlDown))
   If y.Value = "---" Then y.Value = y.Offset(-1, 0).Value
Next y
 
 
'Met sous la forme dd/mm/yyyy la date :
With Worksheets("Rapport mensuel")
    nbLigne2 = .Range("A" & .Rows.Count).End(xlUp).Row
End With
 
Dim ic As Long
Dim vc As Double
Dim jc As Integer, mc As Integer, ac As Integer
Dim sJc As String, sMc As String
Dim sc As String
 
    For ic = 1 To nbLigne2
        If IsDate(Cells(ic, 3)) Then
            vc = CDbl(CDate(Cells(ic, 3)))
            jc = Day(vc)
            mc = Month(vc)
            ac = Year(vc)
 
            Select Case jc
                Case 1 To 9: sJc = "0" & jc
                Case Else: sJc = jc
            End Select
 
            Select Case mc
                Case 1 To 9: sMc = "0" & mc
                Case Else: sMc = mc
            End Select
 
            sc = sJc & "/" & sMc & "/" & ac
 
            Cells(ic, 3).NumberFormat = "General"
            Cells(ic, 3) = Format(sc, "dd/mm/yyyy")
        End If
    Next ic
 
 
'Pour les dates des notes, modifier "2" par le numéro de colonnes ou elle sera apres découpage
Dim ib As Long
Dim vb As Double
Dim jb As Integer, mb As Integer, ab As Integer
Dim sJb As String, sMb As String
Dim sb As String
 
    For ib = 1 To nbLigne2
        If IsDate(Cells(ib, 2)) Then
            vb = CDbl(CDate(Cells(ib, 2)))
            jb = Day(vb)
            mb = Month(vb)
            ab = Year(vb)
 
            Select Case jb
                Case 1 To 9: sJb = "0" & jb
                Case Else: sJb = jb
            End Select
 
            Select Case mb
                Case 1 To 9: sMb = "0" & mb
                Case Else: sMb = mb
            End Select
 
            sb = sJb & "/" & sMb & "/" & ab
 
            Cells(ib, 2).NumberFormat = "General"
            Cells(ib, 2) = Format(sb, "dd/mm/yyyy")
        End If
    Next ib
 
 
'Ajoute une ligne devant "Notes Nom source" pour une meilleure lisibilité du tableau :
cc = ActiveSheet.UsedRange.Rows.Count
    For dc = cc To 1 Step -1
        If Cells(dc, 1) Like "Notes Nom source" Then Rows(dc).EntireRow.Insert Shift:=xlDown 'Insere une ligne avant "Notes Nom Source"
Next dc
 
 
'Supprimer les colonnes G, D et E "Message d'alarme" :
Columns(7).Delete Shift:=xlToLeft
Columns(4).Delete Shift:=xlToLeft
Columns(4).Delete Shift:=xlToLeft
 
 
'Remplacer les caractères "/" par " " :
origString = Array(" / ")
newString = Array("    ")
With Cells.SpecialCells(xlCellTypeConstants)
.Replace origString, newString
End With
 
 
'Inserer 2 colonnes vierges :
Columns(2).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns(2).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
 
 
'Séparer la chaine de mots dans plusieurs colonnes :
ai = [A1].Resize(nbLigne).Value
    Dim ji As Integer
    Dim bi As Variant, ii As Long
For ki = 1 To nbLigne
    bi = Split(ai(ki, 1), "    ") 'séparer les mots espacés de 4 espaces
         For ii = 0 To UBound(bi) 'chaque mots de la phrase
            For ji = ii + 2 To UBound(bi) + 2
    Cells(ki, ji).Value = bi(ii) 'ranger dans la cellule de droite le mot
            Next ji
        Next ii
Next ki
 
 
'Supprimer la 1ère colonne de données collés :
Columns("A:A").Delete Shift:=xlToLeft
 
 
'efface les cellules vides de la colonne 2 en faisant un décallage vers la gauche :
Columns(2).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
 
 
'Supprimer la ligne "Notes Nom Source" :
cf = ActiveSheet.UsedRange.Rows.Count
    For df = cf To 1 Step -1
        If Cells(df, 1) Like "Notes Nom source" Then Rows(df).EntireRow.Delete
Next df
 
 
'ajuster la largeur des colonnes A à K :
Columns("A:K").Columns.AutoFit
 
 
End Sub

Je récapitule :

1er problème :
Je suis toujours en attente d'aide pour les simplifier si possible.

2ème problème :
Pour ce qui est du programme de rangement automatique, il ne fonctionne toujours pas.

3ème problème :
J'ai également un autre problème avec une de mes formules de mon tableau statistique, quand j'exécute un de mes programmes, une de mes forumle (tableau statistique) "casse" le lien avec la plage de données de la feuille ou le programme est exécuté.
Je suis obligée de remplacer manuellement à chaque fois une partie de ma formule "#REF!" par "A:A", y à t'il une solution pour obliger la formule à rester en lien? (même en mettant le symbole $ devant cela casse le lien à chaque execution du programme).

4ème problème :
De plus, 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

08/07/2014, 11h18
Tooth

Bonjour,

Pour améliorer la vitesse de traitement, il faut passer par des tableaux qui sont traités directement en mémoire plutôt que de traiter directement chaque cellule Excel.

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