Boucle sur fichiers dans répertoire

**Eric_03** · 23/11/2019, 07h25

Bonjour,

Alors que le répertoire contient plusieurs fichiers txt, ma variable MonTXT après le 1ere fichier se vide. En enlevant une partie du code entre while MonTXT et le wend la boucle se déroule normalement. Je ne vois pas où je me trompe.

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
Option Explicit
Public MonTXT As String
 
Sub Lire_Fichier()
 
    Dim Extract As String
    Dim Tableau_Extraction As Variant
    Dim CheminTXT As String
    Dim SansTotal As Integer
 
    CheminTXT = ActiveWorkbook.Path & "\TEXT\"
 
    MonTXT = Dir(CheminTXT & "*.txt")
 
    While MonTXT <> ""
 
        Open CheminTXT & MonTXT For Input As #1
 
        Line Input #1, Extract
 
        SansTotal = 0
 
        While Not EOF(1)
 
            If InStr(Extract, " CRED I") > 0 Then
 
                Tableau_Extraction = Split(Extract, "I")
 
                If SansTotal < 11 Then 'Cette condition permet d'exclure le total du fichier analysé
 
                    SansTotal = SansTotal + 1
 
                    Call Ecriture_Excel(Tableau_Extraction, SansTotal)
 
                End If
 
            End If
 
            Line Input #1, Extract
 
        Wend
 
        If SansTotal = 11 Then
 
            SansTotal = 0
 
        End If
 
        Close #1
 
        MonTXT = Dir()
 
    Wend
 
End Sub
 
Sub Ecriture_Excel(Tableau_Extraction As Variant, SansTotal)
 
    Dim i_tab As Long
    Dim Derniere_Ligne  As Long
    Dim Apur1 As Currency
    Dim Apur2 As Currency
    Dim Apur3 As Currency
    Dim TabApurP(5) As String
    Dim TabApurA(5) As String
 
    Derniere_Ligne = Cells(Rows.Count, 1).End(xlUp).Row
    Derniere_Ligne = IIf(Cells(1, 1) = "", 1, Derniere_Ligne + 1)
    i_tab = 2
 
    Do
 
        If i_tab - 1 = 1 Then
 
            ActiveSheet.Cells(Derniere_Ligne, i_tab - 1) = CDbl(Trim(Tableau_Extraction(i_tab))) ' A supprimer
            Apur1 = CDbl(Trim(Tableau_Extraction(i_tab)))
            i_tab = i_tab + 1
 
        ElseIf i_tab - 1 = 2 Then
 
            ActiveSheet.Cells(Derniere_Ligne, i_tab - 1) = CDbl(Trim(Tableau_Extraction(i_tab))) ' A supprimer
            Apur2 = CDbl(Trim(Tableau_Extraction(i_tab)))
            i_tab = i_tab + 1
 
        ElseIf i_tab - 1 = 3 Then
 
            ActiveSheet.Cells(Derniere_Ligne, i_tab - 1) = CDbl(Trim(Tableau_Extraction(i_tab))) ' A supprimer
            Apur3 = CDbl(Trim(Tableau_Extraction(i_tab)))
            i_tab = i_tab + 1
 
        End If
 
    Loop While i_tab <= UBound(Tableau_Extraction) - 2
 
    Dim VarTab As String
 
    Call TypeI(SansTotal, VarTab)
 
    TabApurP(0) = Mid(MonTXT, 8, 6)
    TabApurP(1) = 0
    TabApurP(2) = Apur1
    TabApurP(3) = VarTab
    TabApurP(4) = "Précédent"
    TabApurP(5) = "E"
 
    Dim ResultTabApurP As String
 
    ResultTabApurP = TabApurP(0) & ";" & TabApurP(1) & ";" & TabApurP(2) & ";" & TabApurP(3) & ";" & TabApurP(4) & ";" & TabApurP(5)
 
    If Apur1 > 0 Then
 
        Call EnregistrerAction(ResultTabApurP)
 
    End If
 
    TabApurA(0) = Mid(MonTXT, 8, 6)
    TabApurA(1) = 0
    TabApurA(2) = Apur2 + Apur3
    TabApurA(3) = VarTab
    TabApurA(4) = "Antérieur"
    TabApurA(5) = "E"
 
    Dim ResultTabApurA As String
 
    ResultTabApurA = TabApurA(0) & ";" & TabApurA(1) & ";" & TabApurA(2) & ";" & TabApurA(3) & ";" & TabApurA(4) & ";" & TabApurA(5)
 
    If Apur2 + Apur3 > 0 Then
 
        Call EnregistrerAction(ResultTabApurA)
 
    End If
 
 
End Sub
 
Sub TypeI(SansTotal, VarTab)
 
    Dim x As Integer
 
    x = SansTotal
 
    Select Case x
 
        Case 1: VarTab = "AA"
        Case 2: VarTab = "BB"
        Case 3: VarTab = "CC"
        Case 4: VarTab = "DD"
        Case 5: VarTab = "EE"
        Case 6: VarTab = "FF"
        Case 7: VarTab = "GG"
        Case 8: VarTab = "HH"
        Case 9: VarTab = "II"
        Case 10: VarTab = "JJ"
        Case 11: VarTab = "LL"
 
    End Select
 
End Sub

Merci pour votre aide

Eric

**Eric_03** · 23/11/2019, 09h17

En désactivant les appels:

-Call EnregistrerAction(ResultTabApurP)
-Call EnregistrerAction(ResultTabApurA)

la boucle fonctionne.

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
Function EnregistrerAction(ActionNom As String)
Dim CheminCompletFichierJournal As String
Dim ContenuEnregistrement As String
 
'vérification si le dossier "Excel-Malin" existe sur le bureau
If Len(Dir(ObtenirCheminBureau & "/" & "Excel-Malin", vbDirectory)) = 0 Then
    Call CreerNouveauDossier(ObtenirCheminBureau & "/" & "Excel-Malin")
Else
End If
 
'le nom de fichier journal - peut être fixe ou variable
'vous pouvez choisir parmi les exemples (enlever le commentaire pour la version voulue)
'-->
NomFichierJournal = "FichierJournal-test.txt"
'NomFichierJournal = Year(Date) & Right("0" & Month(Date), 2) & Right("0" & Day(Date), 2) & ".log"
'NomFichierJournal = Environ("UserName") & ".MonSuffixe"
 
CheminCompletFichierJournal = ObtenirCheminBureau & "\" & "Excel-Malin" & "\" & NomFichierJournal
 
'création du contenu à enregistrer
' -> exemple: date, temps, nom d'utilisateur, action
ActionMoment = Now
ContenuEnregistrement = _
Year(ActionMoment) & Right("0" & Month(ActionMoment), 2) & Right("0" & Day(ActionMoment), 2) & ";" _
& Right("0" & Hour(ActionMoment), 2) & ":" & Right("0" & Minute(ActionMoment), 2) & ":" & Right("0" & Second(ActionMoment), 2) & ";" _
& ActionNom
 
'vérifier si le fichier journal existe déjà & enregistrer l'information
VerificationFichierJournal = Len(Dir(CheminCompletFichierJournal))
   If VerificationFichierJournal = 0 Then
    's'il n'existe pas encore -> créer un nouveau
    LogResult = SauvegarderChaineCommeFichierTexte(ContenuEnregistrement, CheminCompletFichierJournal)
  Else
    's'il existe -> ajouter la nouvelle ligne
    LogResult = AjouterAuFichierTexte(ContenuEnregistrement, CheminCompletFichierJournal)
  End If
End Function

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
Public Function AjouterAuFichierTexte(ContenuAAjouter As String, CheminFichier As String)
'par: http://excel-malin.com
 
Dim oFSO As FileSystemObject
Set oFSO = New FileSystemObject
Dim oFS As TextStream
Set oFS = oFSO.OpenTextFile(CheminFichier, ForAppending)
oFS.WriteLine ContenuAAjouter
oFS.Close
Set oFS = Nothing
Set oFSO = Nothing
 
End Function
 
Public Function SauvegarderChaineCommeFichierTexte(Contenu As String, CheminFichier As String)
'par: http://excel-malin.com
 
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim oFile As Object
Set oFile = FSO.CreateTextFile(CheminFichier)
oFile.WriteLine Contenu
oFile.Close
Set FSO = Nothing
Set oFile = Nothing
 
End Function
 
 
Public Function ObtenirCheminBureau() As String
'par: http://excel-malin.com
 
    On Error GoTo ObtenirCheminBureauError
    Dim CheminBureau As String
    CheminBureau = ""
    Dim oWSHShell As Object
    Set oWSHShell = CreateObject("WScript.Shell")
 
    CheminBureau = oWSHShell.SpecialFolders("Desktop")
 
    If (Not (oWSHShell Is Nothing)) Then Set oWSHShell = Nothing
    ObtenirCheminBureau = CheminBureau
 
    Exit Function
ObtenirCheminBureauError:
    If (Not (oWSHShell Is Nothing)) Then Set oWSHShell = Nothing
    ObtenirCheminBureau = ""
End Function
 
Public Function CreerNouveauDossier(NouveauChemin As String)
'par: http://excel-malin.com
 
    On Error GoTo CreerNouveauDossierError
    MkDir (NouveauChemin)
 
Exit Function
CreerNouveauDossierError:
 
End Function

J'ai essayé de mettre en paramètre "MonTXT" dans les appels mais sans succès.

Eric

**Eric_03** · 23/11/2019, 12h23

En mettant en dur le chemin dans la fonction EnregistrerAction

ma boucle s’exécute jusqu'au bout. Il me semble donc que la fonction Dir ne puisse pas être imbriquée

Code :

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

1
2
3
4
If Len(Dir(ObtenirCheminBureau & "/" & "Excel-Malin", vbDirectory)) = 0 Then
    Call CreerNouveauDossier(ObtenirCheminBureau & "/" & "Excel-Malin")
Else
End If

Eric

**Eric_03** · 23/11/2019, 12h46

J'ai résolu mon problème en ajoutant dans ma procédure:

Code :

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

1
2
3
4
5
        Close #1
 
        Kill CheminTXT & MonTXT
 
        MonTXT = Dir(CheminTXT & "*.txt")

Eric

Boucle sur fichiers dans répertoire [XL-2016]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager