Erreur méthode SaveAs

**Vincent32** · 19/01/2012, 09h21

Bonjour à tous,

Voici mon code. Il enregistre des données contenues dans mon classeur dans des répertoires qu'il a dans un premier temps supprimer si ils existent, puis recréée (ceci dans le but de s'assurer que les répertoires ont vides). Excel me crée bien les nouveaux répertoires mais est incapable de réaliser la sauvegarde des données :

Le message suivant s'affiche à l'écran :

"Impossible d'accéder à 'Nom du fichier.txt'. Le fichier peut être en lecture seule, ou vous essayer peut être d'accéderà un emplacement en lecture seule. Il est également possible que le serveur sur lequel est enregistré le document ne réponde pas." => Réessayer / Annuler

Si réessayer => message d'erreur redondant
Si annuler => mode débogage : "La méthode 'SaveAs' de l'objet 'Workbook' a échoué et la ligne suivante est surligné en bleue :

Code :

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

ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Données brutes\txt\Données brutes " & ws1.Cells(1, Col + 1) & ".txt", xlTextWindows 'enregistrement au format txt

Voici le code :

Code :

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

1
2
3
4
5
6
7
8
9
 '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 ThisWorkbook.Path & "\Données brutes\txt\Données brutes " & ws1.Cells(1, Col + 1) & ".txt", xlTextWindows 'enregistrement au format txt
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\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

Merci pour votre aide,

**jfontaine** · 19/01/2012, 09h47

Bonjour,

Tu essais d'enregistrer ton fichier sous ce nom => 'Nom du fichier.txt', ou c'est pour l'exemple?
Si pour exemple, donne nous la valeur de la cellule => ws1.Cells(1, Col + 1)

**Vincent32** · 19/01/2012, 11h40

Oui c'est pour l'exemple, la cellule peut prendre différents noms mais va toujours être du type :

"111219 14h45min_Vinvin_8%MoO3_11,9mg_CO_0 mBar_Pulse 0"

Si ça peut aider je peux mettre 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
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 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
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Raffraichissement écran puis blocage rafraichissement
          Application.ScreenUpdating = True
          Application.ScreenUpdating = False
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    '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 ThisWorkbook.Path & "\Données brutes\txt\Données brutes " & ws1.Cells(1, Col + 1) & ".txt", xlTextWindows 'enregistrement au format txt
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\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 ThisWorkbook.Path & "\Soustraction\txt\Soustraction " & ws1.Cells(1, Col + 2) & ".txt", xlTextWindows 'enregistrement au format txt
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\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 ThisWorkbook.Path & "\Correction ligne de base\txt\Correction ligne de base " & ws1.Cells(1, Col + 1) & ".txt", xlTextWindows 'enregistrement au format txt
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\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 ThisWorkbook.Path & "\N-(N-1)\txt\N-(N-1) " & ws1.Cells(1, Col + 1) & ".txt", xlTextWindows 'enregistrement au format txt
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\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 ThisWorkbook.Path & "\Dérivée première\txt\Dérivée première " & ws1.Cells(1, Col + 1) & ".txt", xlTextWindows 'enregistrement au format txt
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\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 ThisWorkbook.Path & "\Dérivée seconde\txt\Dérivée seconde " & ws1.Cells(1, Col + 1) & ".txt", xlTextWindows 'enregistrement au format txt
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\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) * (Masse.Value * (1 - PAF.Value / 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 ThisWorkbook.Path & "\Correction masse\txt\Correction masse " & ws1.Cells(1, Col + 1) & ".txt", xlTextWindows 'enregistrement au format txt
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\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) * Surface.Value / 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 ThisWorkbook.Path & "\Correction surface\txt\Correction surface " & ws1.Cells(1, Col + 1) & ".txt", xlTextWindows 'enregistrement au format txt
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\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) * (((Masse.Value * (1 - PAF.Value / 100)) * Surface.Value) / (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 ThisWorkbook.Path & "\Correction masse et surface\txt\Correction masse et surface " & ws1.Cells(1, Col + 1) & ".txt", xlTextWindows 'enregistrement au format txt
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\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
        If Commentaire.Text = "" Then 'Si pas de commentaire alors pied de page vide
            For x = 1 To Sheets.Count
                With Sheets(x).PageSetup
                    .CenterHeader = "&B&14&""Arial""" & Echantillon.Value & Chr(10) & "&12&B&A" 'nom échantillon, nom de la feuille en arial gras 12
                    .RightHeader = "&8&""Arial""" & "Masse pastille = " & Masse.Value & " mg (m&YThéo.&Y=20mg)" & Chr(10) & "PAF échantillon = " & PAF.Value & " %" & Chr(10) & "Surface pastille = " & Surface.Value & " mm&X2&X (S&YThéo.&Y=201mm&X2&X)"
                End With
            Next x
        Else 'si commentaire alors pied de page = commentaire
            For x = 1 To Sheets.Count
                With Sheets(x).PageSetup
                    .CenterHeader = "&B&14&""Arial""" & Echantillon.Value & Chr(10) & "&12&B&A" 'nom échantillon, nom de la feuille en arial gras 12
                    .RightHeader = "&8&""Arial""" & "Masse pastille = " & Masse.Value & " mg (m&YThéo.&Y=20mg)" & Chr(10) & "PAF échantillon = " & PAF.Value & " %" & Chr(10) & "Surface pastille = " & Surface.Value & " mm&X2&X (S&YThéo.&Y=201mm&X2&X)"
                    .LeftFooter = "&10&B&""Arial""" & "Commentaire :&B " & Commentaire.Text
                End With
            Next x
        End If
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Sauvegarde
        ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "/" & Echantillon.Value & ".xls"
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    '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
        MsgBox "L'import, le traitement et la sauvegarde des données sont terminés et se sont déroulés correctement" 'Message box pour indiquer la fin de la macro
'-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    'Possibilité d'impression
        Select Case MsgBox("Souhaitez vous imprimer les données traitées ?", vbYesNo, "Impression ?") '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", "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", "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", "Données brutes"
            CreationRepertoire ThisWorkbook.Path & "\Retraitement\Données brutes", "csv"
            CreationRepertoire ThisWorkbook.Path & "\Retraitement\Données brutes", "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", "Soustraction"
            CreationRepertoire ThisWorkbook.Path & "\Retraitement\Soustraction", "csv"
            CreationRepertoire ThisWorkbook.Path & "\Retraitement\Soustraction", "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

Je crois que j'ai trouvé pourquoi il y a un message d'erreur. Par contre je ne vois pas comment pallier à ce problème !

L'erreur vient du fait que :

ThisWorkbook.Path correspond à l'ActiveWorkbook et non au fichier excel de travail (celui ou sont stockées les données).

Il faudrait donc au préalable que j'attribue la valeur ThisWorkbook.Path à une variable (mais de quel type ?)

Qu'en pensez vous, Comment faire ?

**jfontaine** · 19/01/2012, 12h08

Quand tu travailles avec plusieurs classeurs, je te conseil d'utiliser des variables de type Workbook pour les manipuler. Cela rendra ton code plus lisible et évite l'utilisation des Activate et de se perdre dans les ActiveWorkbook et Thisworkbook

**Vincent32** · 19/01/2012, 12h11

Ok mais je ne vois pas comment faire

Il faut que je fasse qqch du type :

Code :

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

1
2
3
Dim W1 as workbook, W2 as workbook
 
Set W1 = ?????.Path' je coince!!!!

**jfontaine** · 19/01/2012, 12h20

Comme cela

Code :

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

1
2
3
4
5
6
Dim W1 as Workbook
 
Set W1 = Workbooks("Classeur1")
ou 
'Si création nouveau classeur
Set W1 = Application.Workbooks.Add

Ensuite pour le chemin

Code :

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

W1.Path

**Vincent32** · 19/01/2012, 12h41

Je suis en train de modifier mon code afin que ça fonctionne correctement : cependant je bloque là dessus :

Code :

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

ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "/" & A & ".xls"

En fait A correspond à une variable de type string contenue ici :

Code :

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

1
2
3
4
5
6
7
8
Private Sub Valider_Click()
Dim A As String
A = Echantillon.Text'Echantillon=valeur d'une textbox de mon userform
    'Importation des données entrées dans l'userform pour la macro
    Call Vinvin 'Appelle macro
 
    Unload UserForm1    'action de fermeture de l'userform
End Sub

Or le code :

Code :

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

ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "/" & A & ".xls"

est contenu dans le module 1 et je pense que c'est pour ça que ça beug non ?

Comment puis je m'y prendre ?

Merci

Erreur méthode SaveAs

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager