Aide simplification programmes VBA

**010714** · 02/07/2014, 08h39

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 :

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

**illight** · 02/07/2014, 09h14

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 :

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

**Tooth** · 02/07/2014, 09h21

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

**010714** · 02/07/2014, 09h29

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
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?"

**010714** · 02/07/2014, 09h37

@ 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

**Tooth** · 02/07/2014, 10h16

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 :

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

**010714** · 02/07/2014, 10h33

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 :

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

**Tooth** · 02/07/2014, 10h49

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

**010714** · 02/07/2014, 11h22

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 :

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

**Tooth** · 03/07/2014, 08h36

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

**010714** · 03/07/2014, 08h53

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?

**illight** · 03/07/2014, 09h20

Sur la ligne 22 :

Code :

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

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

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

Code :

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

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

**010714** · 03/07/2014, 14h40

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.

**illight** · 03/07/2014, 16h29

Code :

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

 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

par ailleurs tu fais une boucle :

Code :

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

Do While compteurBoucle <= nbLigne

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

**010714** · 04/07/2014, 09h48

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

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

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.

**illight** · 04/07/2014, 10h07

Pour l'erreur 1004, j'arrive pas à comprendre d'où vient l'erreur

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 :

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

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é

**Mr Poulpe** · 04/07/2014, 10h12

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

**010714** · 04/07/2014, 10h29

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

**010714** · 08/07/2014, 11h11

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

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

Et

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

**Tooth** · 08/07/2014, 11h18

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.

Aide simplification programmes VBA

Macros et VBA Excel

Discussions similaires

Partager

Partager