Problème boucle Do while-loop et MkDir
Bonjour,
J'ai écrit le code suivant (extrait). Ce qui est bizarre c'est que si je retire les lignes en lien avec la création du dossier/sous-dossiers la boucle se fait bien (traitement des fichiers du dossier A traiter). Mais en laissant ces lignes la boucle ne se fait plus (Do While Len(Fichier) > 0 ... Loop).
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
| Sub Insertion_variables()
On Error Resume Next
'Vérifier si une requête existe dans le dossier
'----------------------------------------------
'Application.DisplayAlerts = False
'Définit le répertoire contenant les fichiers
cheminTEST = "D:\TEST\"
Chemin = "D:\TEST\A TRAITER\"
CheminTalend = "D:\TEST\TALEND\"
'Boucle sur tous les fichiers sql du répertoire.
'-----------------------------------------------
Fichier = Dir(Chemin & "*.sql")
'Si existance d'une requête
'--------------------------
Do While Len(Fichier) > 0
'Ecrit le résultat dans la fenêtre d'exécution (Ctrl+G).
Debug.Print "Longueur du nom de fichier : " & Len(Fichier)
Debug.Print Chemin & Fichier
Debug.Print Fichier
'Insérer les données du fichier texte dans les cellules (Traitement du fichier texte ligne par ligne)
'----------------------------------------------------------------------------------------------------
'Application.ScreenUpdating = False
Dim IndexFichier As Integer
Dim MonFichier As String
Dim ContenuLigne As String
MonFichier = Chemin & Fichier
IndexFichier = FreeFile()
Open MonFichier For Input As #IndexFichier
i = 1
While Not EOF(IndexFichier) '
Line Input #IndexFichier, ContenuLigne
'Traitement à appliquer pour chaque ligne
If Left(ContenuLigne, 1) = "'" Then
Range("A" & i) = "'" & ContenuLigne
Else
Range("A" & i) = ContenuLigne
End If
i = i + 1
Wend
Close #IndexFichier ' ferme le fichier
Application.ScreenUpdating = True
'Rechercher param_ldc pour la création du dossier
'------------------------------------------------
Range("A1").Select
Nb = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To Nb
If Range("A" & i).Value Like "*param_ldc =*" Then
DossParamLDC = Range("A" & i).Value
End If
Next i
If DossParamLDC <> "" Then
DossParamLDC = Replace(DossParamLDC, "define", "")
DossParamLDC = Replace(DossParamLDC, "param_ldc =", "")
DossParamLDC = Replace(DossParamLDC, "'", "")
DossParamLDC = Replace(DossParamLDC, ";", "")
DossParamLDC = Trim(DossParamLDC)
Else
DossParamLDC = "param_ldc_non_trouve"
End If
Debug.Print "Nom sous-dossier (param_ldc) : " & DossParamLDC
'Enregistrement (sauvegarde dans un fichier texte)
'-------------------------------------------------
Dim Chaine As String
Dim LeFichier As String
LeFichier = CheminTalend & "Talend_" & Fichier
Dim f As Integer
f = FreeFile
Open LeFichier For Output As #f
Nb = Sheets("Menu").Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To Nb
Print #f, Cells(i, 1)
Next
Close #f
'MsgBox "Les cellules ont été sauvegardées sous : " & LeFichier
'Supprimer les cellules de la feuille Menu de ce fichier
'-------------------------------------------------------
Sheets("Menu").Cells.Select
Selection.Delete Shift:=xlUp
Sheets("Menu").Range("A1").Select
'Création et insertion de la requête dans le dossier
'---------------------------------------------------
DateDuJour = Date
LeMois = Format(DateDuJour, "MM")
LeMoisLettre = Format(DateDuJour, "MMMM")
LAnnee = Year(DateDuJour)
nomDossier = LeMois & "_" & LeMoisLettre & "_" & LAnnee
Dim Doss As String, sousDoss As String
Doss = cheminTEST & nomDossier '<-- Dossier avec indication du mois et de l'année
Debug.Print "Dossier : " & Doss
If Dir(Doss, vbDirectory) = "" Then MkDir Doss
sousDoss = Doss & "\" & DossParamLDC '<-- sous dossier Param_LDC
Debug.Print "Sous-dossier : " & sousDoss
If Dir(sousDoss, vbDirectory) = "" Then MkDir sousDoss
FileCopy Chemin & Fichier, sousDoss & "\" & Fichier
'Réinitialiser
'-------------
Fichier = Dir()
Loop
'Application.DisplayAlerts = True
MsgBox "Traitement terminé !"
'Application.Quit
End Sub |
Quelqu'un saurait où est mon erreur ?
Merci d'avance si vous avez une solution.
