Problème de code lors du premier lancement après OK

**Vincent32** · 20/01/2012, 08h19

Bonjour,

Lorsque les feuilles de mon classeur sont vides, le premier lancement de la macro s'avère être un échec msg d'erreur suivant :

"Erreur définie par l'application ou l'objet"

pour les deux lignes de codes suivantes :

Code :

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

1
2
'dérivée première de la feuille 3 pour renseigner la feuille 5
        ws1.Range(ws1.Cells(3, 1), ws1.Cells(DerL1 - 1, 1)).Copy ws5.Range("A2") 'Recopie de la colonne A3 à ADerL1-1 de la feuille ws1 dans la feuille ws5

Code :

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

1
2
 'dérivée seconde de la feuille 3 pour renseigner la feuille 6
        ws5.Range(ws5.Cells(3, 1), ws5.Cells(DerL1 - 1, 1)).Copy ws6.Range("A2") 'Recopie de la colonne A3 à ADerL1-1 de la feuille ws5 dans la feuille ws6

Voici le code en entier :

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
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
Public E As String
Public M As String
Public P As String
Public S As String
Public C As String
 
Sub Macro()
    UserForm1.Show
End Sub
 
Sub Vinvin()
    'déclarations des variables
        Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, ws5 As Worksheet, ws6 As Worksheet, ws7 As Worksheet, ws8 As Worksheet, ws9 As Worksheet 'Déclaration des variables
        Dim W1 As Workbook
        Dim fso As New FileSystemObject
        Dim doss As Folder
        Dim fsob As Object 'Déclarations des variables
        Dim FsoRepertoire As Object
        Dim FsoFichier As Object
        Dim i As Long
        Dim C As Integer
        Dim strLigne As String
        Dim str() As String
        Const PremL1 = 2 'Première ligne de données dans la feuille 1
        Const PremC1 = 1 'Première colonne de données dans la feuille 1
        Dim DerL1 As Long 'Dernière ligne de données dans la feuille 1
        Dim DerC1 As Long 'Dernière colonne de données dans la feuille 1
        Dim Col As Long
        Dim Lig As Long
        Dim Lign As Long
        Dim x As Byte
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Attribution de valeurs
        Set ws1 = Worksheets("DDonnées brutes") 'Attribution de valeurL'objet Feuille 1 est attribué à la variable ws1
        Set ws2 = Worksheets("DSoustraction") 'L'objet Feuille 2 est attribué à la variable ws2
        Set ws3 = Worksheets("DCorrection ligne de base") 'L'objet Feuille 3 est attribué à la variable ws3
        Set ws4 = Worksheets("DN-(N-1)")
        Set ws5 = Worksheets("DDérivée première")
        Set ws6 = Worksheets("DDérivée seconde")
        Set ws7 = Worksheets("DCorrection masse")
        Set ws8 = Worksheets("DCorrection surface")
        Set ws9 = Worksheets("DCorrection totale")
        Set fsob = CreateObject("Scripting.FileSystemObject") 'Attribution de valeurs
        Set FsoRepertoire = fsob.GetFolder(ThisWorkbook.Path & "\Spectres originaux.dpt") 'nom du répertoire
        DerL1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row 'Recherche de la dernière ligne renseignée dans la colonne A de la feuille 1
        DerC1 = ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column 'Recherche de la dernière colonne renseignée dans la ligne 1 de la feuille 1
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Suppression du dossier retraitement si il existe
        If fso.FolderExists(ThisWorkbook.Path & "\Retraitement") Then 'Vérifie si le répertoire existe.
            Set doss = fso.GetFolder(ThisWorkbook.Path & "\Retraitement") 'Accède au dossier
            doss.Delete
        End If
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Création des répertoires de stockage des fichiers
        Call creation
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Bloccage du rafraichissement des feuilles du classeur
        Application.ScreenUpdating = False
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Suppression des données contenues dans les feuilles du classeur
        ws1.Range("A:IV").ClearContents 'suppression des données contenues dans les feuilles
        ws2.Range("A:IV").ClearContents
        ws3.Range("A:IV").ClearContents
        ws4.Range("A:IV").ClearContents
        ws5.Range("A:IV").ClearContents
        ws6.Range("A:IV").ClearContents
        ws7.Range("A:IV").ClearContents
        ws8.Range("A:IV").ClearContents
        ws9.Range("A:IV").ClearContents
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Importation des données .dpt dans le classeur
        C = 2 'Boucle sur fichiers du repertoire
            For Each FsoFichier In FsoRepertoire.Files
                i = 2
                str = Split(FsoFichier.Name, ".") 'Vérifie si le fichier a l'extension souhaité
                    If str(UBound(str)) = "dpt" Then
                        Sheets("DDonnées brutes").Cells(1, C).Value = NomFichierSansExtension(FsoFichier.Name)
                        Open FsoFichier.Path For Input As #1 'ouvre le fichier
                            Do While Not EOF(1) 'Boucle sur chaque ligne du fichier
                                Line Input #1, strLigne
                                str = Split(strLigne, Chr(9))
                                Sheets("DDonnées brutes").Cells(i, C).Value = str(1) 'insere la ligne dans la cellule
                                If C = 2 Then
                                    Sheets("DDonnées brutes").Cells(i, 1).Value = str(0)
                                End If
                                i = i + 1
                            Loop
                        Close #1
                        C = C + 1
                    End If
            Next
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Rafraichissement des feuilles du classeur
        Application.ScreenUpdating = True
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Bloccage du rafraichissement des feuilles du classeur
        Application.ScreenUpdating = False
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Sauvegarde
        ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "/" & E & ".xls"
        Set W1 = Workbooks(E) 'attribution de la feuille de classeur
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Enregistrement données brutes
        For Col = PremC1 To DerC1 - 1 'boucle sur colonne
            Workbooks.Add 1 'ajout d'un classeur avec 1 feuille
            ws1.Range(ws1.Cells(2, 1), ws1.Cells(DerL1, 1)).Copy [A1] 'copie des colonnes qui vont bien dans le nouveau classeur
            ws1.Range(ws1.Cells(2, Col + 1), ws1.Cells(DerL1, Col + 1)).Copy [B1] 'copie des colonnes qui vont bien dans le nouveau classeur
            ActiveWorkbook.SaveAs W1.Path & "\Retraitement\Données brutes\txt\Données brutes " & ws1.Cells(1, Col + 1) & ".txt", xlTextWindows 'enregistrement au format txt
            ActiveWorkbook.SaveAs W1.Path & "\Retraitement\Données brutes\csv\Données brutes " & ws1.Cells(1, Col + 1) & ".csv", xlCSV, Local:=True 'enregistrement au format csv
            ActiveWorkbook.Close False 'fermeture du classeur texte
        Next Col
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'soustraire la colonne B de la feuille 1 à toutes les autres colonnes pour renseigner la feuille 2
        ws1.Range("A:A").Copy ws2.Range("A:A") 'Recopie de la colonne A de la feuille ws1 dans la feuille ws2
        For Col = PremC1 To DerC1 - 1 'boucle sur colonne
            ws1.Cells(1, 1).Copy ws2.Cells(1, 1) 'recopie les entêtes de colonnes
            If Col > 1 Then 'si colonne supérieure à A alors recopie en tête de colonne
                ws1.Cells(1, Col + 1).Copy ws2.Cells(1, Col)
            End If
        Next Col
        For Col = PremC1 To DerC1 - 2 'boucle sur les colonnes
            For Lig = PremL1 To DerL1 'boucle sur ligne
                ws2.Cells(Lig, Col + 1) = ws1.Cells(Lig, Col + 2) - ws1.Cells(Lig, PremC1 + 1) 'formule soustraction colonne B à toutes les autres
            Next Lig
            'Enregistrement soustraction
            Workbooks.Add 1 'ajout d'un classeur avec 1 feuille
            ws2.Range(ws2.Cells(2, 1), ws2.Cells(DerL1, 1)).Copy [A1] 'copie des colonnes qui vont bien dans le nouveau classeur
            ws2.Range(ws2.Cells(2, Col + 1), ws2.Cells(DerL1, Col + 1)).Copy [B1] 'copie des colonnes qui vont bien dans le nouveau classeur
            ActiveWorkbook.SaveAs W1.Path & "\Retraitement\Soustraction\txt\Soustraction " & ws1.Cells(1, Col + 2) & ".txt", xlTextWindows 'enregistrement au format txt
            ActiveWorkbook.SaveAs W1.Path & "\Retraitement\Soustraction\csv\Soustraction " & ws1.Cells(1, Col + 1) & ".csv", xlCSV, Local:=True 'enregistrement au format csv
            ActiveWorkbook.Close False 'fermeture du classeur texte
        Next Col
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'soustraire la ligne 1090 de la feuille 2 à toutes les autres lignes pour renseigner la feuille 3
        ws1.Range("A:A").Copy ws3.Range("A:A") 'Recopie de la colonne A de la feuille ws1 dans la feuille ws3
        For Col = PremC1 To DerC1 - 1 'boucle sur colonne
            ws1.Cells(1, 1).Copy ws3.Cells(1, 1) 'recopie les entêtes de colonnes
            If Col > 1 Then 'si colonne supérieure à A alors recopie en tête de colonne
                ws1.Cells(1, Col + 1).Copy ws3.Cells(1, Col)
            End If
        Next Col
        For Col = PremC1 To DerC1 - 2 'boucle sur les colonnes
            For Lig = PremL1 To DerL1 'boucle sur les lignes
                ws3.Cells(Lig, Col + 1) = ws2.Cells(Lig, Col + 1) - ws2.Cells(1090, Col + 1) 'formule soustraction ligne 109 à toutes les autres
            Next Lig
            'Enregistrement correction ligne de base
            Workbooks.Add 1 'ajout d'un classeur avec 1 feuille
            ws3.Range(ws3.Cells(2, 1), ws3.Cells(DerL1, 1)).Copy [A1] 'copie des colonnes qui vont bien dans le nouveau classeur
            ws3.Range(ws3.Cells(2, Col + 1), ws3.Cells(DerL1, Col + 1)).Copy [B1] 'copie des colonnes qui vont bien dans le nouveau classeur
            ActiveWorkbook.SaveAs W1.Path & "\Retraitement\Correction ligne de base\txt\Correction ligne de base " & ws1.Cells(1, Col + 1) & ".txt", xlTextWindows 'enregistrement au format txt
            ActiveWorkbook.SaveAs W1.Path & "\Retraitement\Correction ligne de base\csv\Correction ligne de base " & ws1.Cells(1, Col + 1) & ".csv", xlCSV, Local:=True 'enregistrement au format csv
            ActiveWorkbook.Close False 'fermeture du classeur texte
        Next Col
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'N-(N-1)
        ws1.Range("A:A").Copy ws4.Range("A:A") 'Recopie de la colonne A de la feuille ws1 dans la feuille ws4
        For Col = PremC1 To DerC1 - 1 'boucle sur colonne
            ws1.Cells(1, 1).Copy ws4.Cells(1, 1) 'recopie les entêtes de colonnes
            If Col > 1 Then 'si colonne supérieure à A alors recopie en tête de colonne
                ws1.Cells(1, Col + 1).Copy ws4.Cells(1, Col)
            End If
        Next Col
        For Col = PremC1 To DerC1 - 2 'boucle sur les colonnes
            For Lig = PremL1 To DerL1 'boucle sur les lignes
                ws4.Cells(Lig, Col + 1) = ws3.Cells(Lig, Col + 2) - ws3.Cells(Lig, Col + 1) 'formule N-(N-1)
            Next Lig
            'Enregistrement N-(N-1)
            Workbooks.Add 1 'ajout d'un classeur avec 1 feuille
            ws4.Range(ws4.Cells(2, 1), ws4.Cells(DerL1, 1)).Copy [A1] 'copie des colonnes qui vont bien dans le nouveau classeur
            ws4.Range(ws4.Cells(2, Col + 1), ws4.Cells(DerL1, Col + 1)).Copy [B1] 'copie des colonnes qui vont bien dans le nouveau classeur
            ActiveWorkbook.SaveAs W1.Path & "\Retraitement\N-(N-1)\txt\N-(N-1) " & ws1.Cells(1, Col + 1) & ".txt", xlTextWindows 'enregistrement au format txt
            ActiveWorkbook.SaveAs W1.Path & "\Retraitement\N-(N-1)\csv\N-(N-1) " & ws1.Cells(1, Col + 1) & ".csv", xlCSV, Local:=True 'enregistrement au format csv
            ActiveWorkbook.Close False 'fermeture du classeur texte
        Next Col
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'dérivée première de la feuille 3 pour renseigner la feuille 5
        ws1.Range(ws1.Cells(3, 1), ws1.Cells(DerL1 - 1, 1)).Copy ws5.Range("A2") 'Recopie de la colonne A3 à ADerL1-1 de la feuille ws1 dans la feuille ws5
        For Col = PremC1 To DerC1 - 1 'boucle sur colonne
            ws1.Cells(1, 1).Copy ws5.Cells(1, 1) 'recopie les entêtes de colonnes
            If Col > 1 Then 'si colonne supérieure à A alors recopie en tête de colonne
                ws1.Cells(1, Col + 1).Copy ws5.Cells(1, Col)
            End If
        Next Col
        For Col = PremC1 To DerC1 - 2 'boucle sur les colonnes
            For Lig = PremL1 + 1 To DerL1 - 1 'boucle sur les lignes
                ws5.Cells(Lig - 1, Col + 1) = (ws3.Cells(Lig + 1, Col + 1) - ws3.Cells(Lig - 1, Col + 1)) / (ws3.Cells(Lig + 1, 1) - ws3.Cells(Lig - 1, 1)) 'formule dérivée première
            Next Lig
            'Enregistrement dérivée première
            Workbooks.Add 1 'ajout d'un classeur avec 1 feuille
            ws5.Range(ws5.Cells(2, 1), ws5.Cells(DerL1, 1)).Copy [A1] 'copie des colonnes qui vont bien dans le nouveau classeur
            ws5.Range(ws5.Cells(2, Col + 1), ws5.Cells(DerL1, Col + 1)).Copy [B1] 'copie des colonnes qui vont bien dans le nouveau classeur
            ActiveWorkbook.SaveAs W1.Path & "\Retraitement\Dérivée première\txt\Dérivée première " & ws1.Cells(1, Col + 1) & ".txt", xlTextWindows 'enregistrement au format txt
            ActiveWorkbook.SaveAs W1.Path & "\Retraitement\Dérivée première\csv\Dérivée première " & ws1.Cells(1, Col + 1) & ".csv", xlCSV, Local:=True 'enregistrement au format csv
            ActiveWorkbook.Close False 'fermeture du classeur texte
        Next Col
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'dérivée seconde de la feuille 3 pour renseigner la feuille 6
        ws5.Range(ws5.Cells(3, 1), ws5.Cells(DerL1 - 1, 1)).Copy ws6.Range("A2") 'Recopie de la colonne A3 à ADerL1-1 de la feuille ws5 dans la feuille ws6
        For Col = PremC1 To DerC1 - 1 'boucle sur colonne
            ws1.Cells(1, 1).Copy ws6.Cells(1, 1) 'recopie les entêtes de colonnes
            If Col > 1 Then 'si colonne supérieure à A alors recopie en tête de colonne
                ws1.Cells(1, Col + 1).Copy ws6.Cells(1, Col)
            End If
        Next Col
        For Col = PremC1 To DerC1 - 2 'boucle sur les colonnes
            For Lig = PremL1 + 1 To DerL1 - 1 'boucle sur les lignes
                ws6.Cells(Lig - 1, Col + 1) = (ws5.Cells(Lig + 1, Col + 1) - ws5.Cells(Lig - 1, Col + 1)) / (ws5.Cells(Lig + 1, 1) - ws5.Cells(Lig - 1, 1)) 'formule dérivée seconde
            Next Lig
            'Enregistrement soustraction
            Workbooks.Add 1 'ajout d'un classeur avec 1 feuille
            ws6.Range(ws6.Cells(2, 1), ws6.Cells(DerL1, 1)).Copy [A1] 'copie des colonnes qui vont bien dans le nouveau classeur
            ws6.Range(ws6.Cells(2, Col + 1), ws6.Cells(DerL1, Col + 1)).Copy [B1] 'copie des colonnes qui vont bien dans le nouveau classeur
            ActiveWorkbook.SaveAs W1.Path & "\Retraitement\Dérivée seconde\txt\Dérivée seconde " & ws1.Cells(1, Col + 1) & ".txt", xlTextWindows 'enregistrement au format txt
            ActiveWorkbook.SaveAs W1.Path & "\Retraitement\Dérivée seconde\csv\Dérivée seconde " & ws1.Cells(1, Col + 1) & ".csv", xlCSV, Local:=True 'enregistrement au format csv
            ActiveWorkbook.Close False 'fermeture du classeur texte
        Next Col
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Correction masse
        ws1.Range("A:A").Copy ws7.Range("A:A") 'Recopie de la colonne A de la feuille ws1 dans la feuille ws4
        For Col = PremC1 To DerC1 - 1 'boucle sur colonne
            ws1.Cells(1, 1).Copy ws7.Cells(1, 1) 'recopie les entêtes de colonnes
            If Col > 1 Then 'si colonne supérieure à A alors recopie en tête de colonne
                ws1.Cells(1, Col + 1).Copy ws7.Cells(1, Col)
            End If
        Next Col
        For Col = PremC1 To DerC1 - 2 'boucle sur les colonnes
            For Lig = PremL1 To DerL1 'boucle sur les lignes
                ws7.Cells(Lig, Col + 1) = ws3.Cells(Lig, Col + 1) * (M * (1 - P / 100)) / 20 'formule correction masse : masse pastille*(1-PAF/100)/20
            Next Lig
            'Enregistrement Correction masse
            Workbooks.Add 1 'ajout d'un classeur avec 1 feuille
            ws7.Range(ws7.Cells(2, 1), ws7.Cells(DerL1, 1)).Copy [A1] 'copie des colonnes qui vont bien dans le nouveau classeur
            ws7.Range(ws7.Cells(2, Col + 1), ws7.Cells(DerL1, Col + 1)).Copy [B1] 'copie des colonnes qui vont bien dans le nouveau classeur
            ActiveWorkbook.SaveAs W1.Path & "\Retraitement\Correction masse\txt\Correction masse " & ws1.Cells(1, Col + 1) & ".txt", xlTextWindows 'enregistrement au format txt
            ActiveWorkbook.SaveAs W1.Path & "\Retraitement\Correction masse\csv\Correction masse " & ws1.Cells(1, Col + 1) & ".csv", xlCSV, Local:=True 'enregistrement au format csv
            ActiveWorkbook.Close False 'fermeture du classeur texte
        Next Col
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Correction surface
        ws1.Range("A:A").Copy ws8.Range("A:A") 'Recopie de la colonne A de la feuille ws1 dans la feuille ws4
        For Col = PremC1 To DerC1 - 1 'boucle sur colonne
            ws1.Cells(1, 1).Copy ws8.Cells(1, 1) 'recopie les entêtes de colonnes
            If Col > 1 Then 'si colonne supérieure à A alors recopie en tête de colonne
                ws1.Cells(1, Col + 1).Copy ws8.Cells(1, Col)
            End If
        Next Col
        For Col = PremC1 To DerC1 - 2 'boucle sur les colonnes
            For Lig = PremL1 To DerL1 'boucle sur les lignes
                ws8.Cells(Lig, Col + 1) = ws3.Cells(Lig, Col + 1) * S / 201 'formule correction surface : surface pastille/201
            Next Lig
            'Enregistrement Correction masse
            Workbooks.Add 1 'ajout d'un classeur avec 1 feuille
            ws8.Range(ws8.Cells(2, 1), ws8.Cells(DerL1, 1)).Copy [A1] 'copie des colonnes qui vont bien dans le nouveau classeur
            ws8.Range(ws8.Cells(2, Col + 1), ws8.Cells(DerL1, Col + 1)).Copy [B1] 'copie des colonnes qui vont bien dans le nouveau classeur
            ActiveWorkbook.SaveAs W1.Path & "\Retraitement\Correction surface\txt\Correction surface " & ws1.Cells(1, Col + 1) & ".txt", xlTextWindows 'enregistrement au format txt
            ActiveWorkbook.SaveAs W1.Path & "\Retraitement\Correction surface\csv\Correction surface " & ws1.Cells(1, Col + 1) & ".csv", xlCSV, Local:=True 'enregistrement au format csv
            ActiveWorkbook.Close False 'fermeture du classeur texte
        Next Col
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Correction masse et surface
        ws1.Range("A:A").Copy ws9.Range("A:A") 'Recopie de la colonne A de la feuille ws1 dans la feuille ws4
        For Col = PremC1 To DerC1 - 1 'boucle sur colonne
            ws1.Cells(1, 1).Copy ws9.Cells(1, 1) 'recopie les entêtes de colonnes
            If Col > 1 Then 'si colonne supérieure à A alors recopie en tête de colonne
                ws1.Cells(1, Col + 1).Copy ws9.Cells(1, Col)
            End If
        Next Col
        For Col = PremC1 To DerC1 - 2 'boucle sur les colonnes
            For Lig = PremL1 To DerL1 'boucle sur les lignes
                ws9.Cells(Lig, Col + 1) = ws3.Cells(Lig, Col + 1) * (((M * (1 - P / 100)) * S) / (20 * 201)) 'formule correction masse et surface : (masse pastille*(1-PAF/100))*surface pastille/(20*201)
            Next Lig
            'Enregistrement Correction masse
            Workbooks.Add 1 'ajout d'un classeur avec 1 feuille
            ws9.Range(ws9.Cells(2, 1), ws9.Cells(DerL1, 1)).Copy [A1] 'copie des colonnes qui vont bien dans le nouveau classeur
            ws9.Range(ws9.Cells(2, Col + 1), ws9.Cells(DerL1, Col + 1)).Copy [B1] 'copie des colonnes qui vont bien dans le nouveau classeur
            ActiveWorkbook.SaveAs W1.Path & "\Retraitement\Correction masse et surface\txt\Correction masse et surface " & ws1.Cells(1, Col + 1) & ".txt", xlTextWindows 'enregistrement au format txt
            ActiveWorkbook.SaveAs W1.Path & "\Retraitement\Correction masse et surface\csv\Correction masse et surface " & ws1.Cells(1, Col + 1) & ".csv", xlCSV, Local:=True 'enregistrement au format csv
            ActiveWorkbook.Close False 'fermeture du classeur texte
        Next Col
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'En tête et pied de page des feuilles
        For x = 1 To Sheets.Count
    With Sheets(x).PageSetup
        .CenterHeader = "&B&14&""Arial""" & E & Chr(10) & "&12&B&A"    'nom échantillon, nom de la feuille en arial gras 12
        .RightHeader = "&8&""Arial""" & "Masse pastille = " & M & " mg (m&YThéo.&Y=20mg)" & Chr(10) & "PAF échantillon = " & P & " %" & Chr(10) & "Surface pastille = " & S & " mm&X2&X (S&YThéo.&Y=201mm&X2&X)"
        If Commentaire <> "" Then                 'Si pas de commentaire alors pied de page vide
            .LeftFooter = "&10&B&""Arial""" & "Commentaire :&B " & Commentaire
        Else
            .LeftFooter = ""
        End If
    End With
Next x
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Sauvegarde
        W1.Save
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Libère les ressources
        Set ws1 = Nothing
        Set ws2 = Nothing
        Set ws3 = Nothing
        Set ws4 = Nothing
        Set ws5 = Nothing
        Set ws6 = Nothing
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Rafraichissement de l'écran
        Application.ScreenUpdating = True
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Message de fin de macro et Possibilité d'impression
            Select Case MsgBox("L'import, le traitement et la sauvegarde des données sont terminés et se sont déroulés correctement" & Chr(10) & Chr(10) & "Souhaitez vous imprimer les données traitées ?", vbYesNo + vbQuestion, "Fin du traitement des données. Impression des graphes ?") 'MsgBox Oui + Non
            Case vbYes 'procédure si click sur Oui=>ouverture userform 2 pour impression
                UserForm2.Show
            Case vbNo 'procédure si click sur Non => fin de la macro (il ne se passe rien)
 
        End Select
End Sub
 
Public Function NomFichierSansExtension(nomFichier As String) As String 'suppresion de l'extension pour les noms de fichiers
    Dim P As Integer
    P = InStrRev(nomFichier, ".")
    If P > 0 Then
        NomFichierSansExtension = Mid(nomFichier, 1, P - 1)
    Else
        NomFichierSansExtension = nomFichier
    End If
End Function
 
Sub creation() 'création répertoires
    CreationRepertoire ThisWorkbook.Path, "Retraitement" 'Exemple : CreationRepertoire "C:\Documents and Settings\dossier", "Archives" crée un dossier "Archives" dans "C:\Documents and Settings\dossier"
        CreationRepertoire ThisWorkbook.Path & "\Retraitement", "Données brutes"
            CreationRepertoire ThisWorkbook.Path & "\Retraitement\Données brutes", "csv"
            CreationRepertoire ThisWorkbook.Path & "\Retraitement\Données brutes", "txt"
        CreationRepertoire ThisWorkbook.Path & "\Retraitement", "Soustraction"
            CreationRepertoire ThisWorkbook.Path & "\Retraitement\Soustraction", "csv"
            CreationRepertoire ThisWorkbook.Path & "\Retraitement\Soustraction", "txt"
        CreationRepertoire ThisWorkbook.Path & "\Retraitement", "Correction ligne de base"
            CreationRepertoire ThisWorkbook.Path & "\Retraitement\Correction ligne de base", "csv"
            CreationRepertoire ThisWorkbook.Path & "\Retraitement\Correction ligne de base", "txt"
        CreationRepertoire ThisWorkbook.Path & "\Retraitement", "N-(N-1)"
            CreationRepertoire ThisWorkbook.Path & "\Retraitement\N-(N-1)", "csv"
            CreationRepertoire ThisWorkbook.Path & "\Retraitement\N-(N-1)", "txt"
        CreationRepertoire ThisWorkbook.Path & "\Retraitement", "Dérivée première"
            CreationRepertoire ThisWorkbook.Path & "\Retraitement\Dérivée première", "csv"
            CreationRepertoire ThisWorkbook.Path & "\Retraitement\Dérivée première", "txt"
        CreationRepertoire ThisWorkbook.Path & "\Retraitement", "Dérivée seconde"
            CreationRepertoire ThisWorkbook.Path & "\Retraitement\Dérivée seconde", "csv"
            CreationRepertoire ThisWorkbook.Path & "\Retraitement\Dérivée seconde", "txt"
        CreationRepertoire ThisWorkbook.Path & "\Retraitement", "Correction masse"
            CreationRepertoire ThisWorkbook.Path & "\Retraitement\Correction masse", "csv"
            CreationRepertoire ThisWorkbook.Path & "\Retraitement\Correction masse", "txt"
        CreationRepertoire ThisWorkbook.Path & "\Retraitement", "Correction surface"
            CreationRepertoire ThisWorkbook.Path & "\Retraitement\Correction surface", "csv"
            CreationRepertoire ThisWorkbook.Path & "\Retraitement\Correction surface", "txt"
        CreationRepertoire ThisWorkbook.Path & "\Retraitement", "Correction masse et surface"
            CreationRepertoire ThisWorkbook.Path & "\Retraitement\Correction masse et surface", "csv"
            CreationRepertoire ThisWorkbook.Path & "\Retraitement\Correction masse et surface", "txt"
End Sub
 
Sub CreationRepertoire(DossierParent As String, NomRep As String)
    Dim chemin As String
    If Dir(DossierParent, vbDirectory + vbHidden) <> "" Then 'Vérifie si le répertoire existe.
        'Vérifie que le dossier à créer n'existe pas déjà dans le répertoire
        If Dir(DossierParent & "\" & NomRep, vbDirectory + vbHidden) = "" Then _
            MkDir DossierParent & "\" & NomRep
    End If
End Sub

A quoi est ce dû, comment puis je pallier à ce dysfonctionnement ?

A noter que lorsque je mets fin à la macro et que je la relance, elle semble fonctionner correctement.

Merci pour votre aide

**pijaku** · 20/01/2012, 09h31

Bonjour,

Tu dis :

Lorsque les feuilles de mon classeur sont vides, ma macro plante sur les lignes :

Code :

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

ws1.Range(ws1.Cells(3, 1), ws1.Cells(DerL1 - 1, 1)).Copy ws5.Range("A2")

Tu affectes, à la variable DerL1 le numéro de ta dernière ligne saisie :

Code :

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

DerL1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row

Si tu n'as pas de valeur dans ta colonne A, DerL1 = 1.
Dans ton code, tu utilises : DerL1 - 1, soit : ligne 0. Or Excel ne connais pas. D'ou le message : "Erreur définie par l'application ou l'objet"
Il faut donc ajouter un test après cette ligne :

Code :

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

DerL1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row

du style :

Code :

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

1
2
DerL1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
If DerLig1 < 3 Then DerLig1 = 3

**Vincent32** · 20/01/2012, 10h59

Merci pour ton aide.

Le fait de rajouter un if supprime le message d'erreur mais la macro ne réalise aucun des traitements demandés (il recopie la colonne A pour les 3 premiers items, puis fais des choses bizarres ensuite toujours au niveau de la recopie de la cellule A en outre, la macro ne réalise pas les calculs pour les autres colonnes):

- Soustraction
- Correction ligne de base
- N-N(-1)
- Dérivée première
- Dérivée seconde
- Correction masse
- Correction surface
- Correction masse et surface

Cordialement

**pijaku** · 20/01/2012, 11h57

Excuse moi, mais tu nous donne un code de 365 lignes, sans fichier exemple, c'est difficile de tâtonner pour trouver ce qui ne convient pas.
Bon, j'ai regardé de près ton code, et je ne suis pas sur que même avec un exemple ce serait mieux... Mais bon, tu vois.
Nous ne conanissons pas, ni la structure, ni le formatage de tes données, donc dur dur de te dire pourquoi tes opérations ne fonctionnent pas.

conseil :
lance ta macro en pas à pas (je sais c'est fastidieux) et étudie le comportement de tes variables, comment ça se traduis dans tes feuilles.
Pour cela :
Sous VBe : clic n'importe ou dans ton code de procédure vinvin et appuies sur F8 moultes moultes fois... Lors du survol d'une variable, tu peux voir qu'elle valeur lui est affectée, une fois la ligne passée.
Après chaque opération, regarde dans ta feuille ce qui se passe, tu seras plus à même de comprendre ce qui ne fonctionne pas.

N'hésite pas en tout cas, nous t'aiderons au maximum de nos possibilités.

**Vincent32** · 20/01/2012, 13h04

Merci Pijaku pour le temps que tu m'accordes.

Je joins au cas où mon fichier avec un répertoire contenant les données que la macro récupère et traite le tout est au format zip (en 2 fichiers à cause de la taille.

De mon côté je continue de regarder et d'essayer mais je n'ai rien de concluant ...

**pijaku** · 20/01/2012, 13h27

Je ne possède pas 7zip au boulot, donc... "Archive au format inconnue" sous winrar...
Désolé.

**Vincent32** · 20/01/2012, 13h31

Voilà les fichiers en .zip

**pijaku** · 20/01/2012, 13h42

Je ne peux toujours pas décompresser tes fichiers...

**Vincent32** · 20/01/2012, 22h16

Je suis désolé je n'ai pas les moyens de vous mettre ces fichiers en .rar.

Soit vous aurez l'opportunité de télécharger ces fichiers ultérieurement (ou en utilisant la version portable de 7zip). Soit je peux vous envoyer les fichiers sur une adresse mail (sans les compresser). Soit je vois les envoie quand j'ai trouvé un archiveur de type .rar (hors travail).

En tout cas merci du temps que vous m'accordez et de l'aide que vous m'apportez

j'apprécie énormément.

Merci beaucoup pour ton aide Pijaku.

Si tu n'as pas de valeur dans ta colonne A, DerL1 = 1.
Dans ton code, tu utilises : DerL1 - 1, soit : ligne 0. Or Excel ne connais pas. D'ou le message : "Erreur définie par l'application ou l'objet"

Ceci était capital pour pallier à ceci pas besoin de boucle if. "Il suffisait de déplacer les variables DerL1 et DerC1 après la partie :

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
'Importation des données .dpt dans le classeur
        C = 2 'Boucle sur fichiers du repertoire
            For Each FsoFichier In FsoRepertoire.Files
                i = 2
                str = Split(FsoFichier.Name, ".") 'Vérifie si le fichier a l'extension souhaité
                    If str(UBound(str)) = "dpt" Then
                        Sheets("DDonnées brutes").Cells(1, C).Value = NomFichierSansExtension(FsoFichier.Name)
                        Open FsoFichier.Path For Input As #1 'ouvre le fichier
                            Do While Not EOF(1) 'Boucle sur chaque ligne du fichier
                                Line Input #1, strLigne
                                str = Split(strLigne, Chr(9))
                                Sheets("DDonnées brutes").Cells(i, C).Value = str(1) 'insere la ligne dans la cellule
                                If C = 2 Then
                                    Sheets("DDonnées brutes").Cells(i, 1).Value = str(0)
                                End If
                                i = i + 1
                            Loop
                        Close #1
                        C = C + 1
                    End If
            Next
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Rafraichissement des feuilles du classeur
        Application.ScreenUpdating = True
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Bloccage du rafraichissement des feuilles du classeur
        Application.ScreenUpdating = False
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Sauvegarde
        ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "/" & E & ".xls"
        Set W1 = Workbooks(E) 'attribution de la feuille de classeur

Comme des données viennent d'être importées DerL1 est différent de 1 ce qui règle le problème. En résumé DerL1 et DerC1 ont été déclarés trop tôt dans le code => La solution : les déplacés après l'importation de données, la réactualisation du classeur et la sauvegarde de ce dernier.

Merci beaucoup pour tes lumières :avePijaku

: sans toi je n'aurais pas trouvé

Excellent week end

**pijaku** · 21/01/2012, 09h17

Bonjour,
Je revenais pour voir vos fichiers, je vois que vous y êtes parvenu seul. Tant mieux.
A une prochaine fois alors.
N'hésitez pas.

Problème de code lors du premier lancement après OK

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager