creer un fichier récapitulatif de touts les fichiers fermé se trouvant dans un répertoire

**maximilien59** · 21/07/2020, 16h35

Bonjour a tous les développeurs.

Je vous contact du fait que je suis bloqué sur la création de mon fichier excel.

Ce fichier a pour but de répertorier chaque fichiers ".ASC" se trouvant dans un répertoire en tableau.

L'idée est de lister le Nom de Fichier, Date de Modification, le nombre total de ligne non vide , et les lignes selon conditions afin de pouvoir faire des indicateurs.

J'ai commencé par le code ci-dessous mais j'arrive pas à mettre en place le code qui permet de compter les enregistrements de chaque fichiers fermé du répertoire.

Pouvez-vous me débloquer?

Je vous remercie

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
Sub TestListeFichiers()
    Dim Dossier As String
 
    'Définit le répertoire pour débuter la recherche de fichiers.
    '(Attention à ne pas indiquer un répertoire qu contient trop de sous-dossiers ou de
    'fichiers, sinon le temps de traitement va être très long).
    Dossier = "C:\Users\Desktop\Nouveau dossier(3)"
 
    'Appelle la procédure de recherche des fichiers
    ListeFichiers Dossier
 
    'Ajuste la largeur des colonnes A:E en fonction du contenu des cellules.
    Columns("A:E").AutoFit
    MsgBox "Terminé"
 
End Sub
 
Sub ListeFichiers(Repertoire As String)
    '
    'Nécessite d'activer la référence "Microsoft Scripting RunTime"
        'Dans l'éditeur de macros (Alt+F11):
        'Menu Outils
        'Références
        'Cochez la ligne "Microsoft Scripting RunTime".
        'Cliquez sur le bouton OK pour valider.
 
    Dim Fso As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim SubFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim i As Long
 
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = Fso.GetFolder(Repertoire)
 
 'Mise à zero de la page
    Cells.Select
    Selection.ClearContents
 
 'Titre des colonnes
    Range("a1").Value = "Nom du fichier"
    Range("b1").Value = "Date de modification"
    Range("c1").Value = "Nombre de données fichier"
    Range("d1").Value = "Nombre de Ligne total du fichier"    '-> LE BUT est de pouvoir créer un pourcentage et graphique par la suite
    Range("e1").Value = "Nombre de Ligne contenant un '1'"    '-> LE BUT est de pouvoir créer un pourcentage et graphique par la suite
    Range("f1").Value = "Nombre de Ligne contenant un '2'"    '-> LE BUT est de pouvoir créer un pourcentage et graphique par la suite
 
 'Mise en forme 1er ligne
 
    Rows("1:1").Select
    Selection.Font.Bold = True
    Selection.Font.Size = 12
 
    'Récupère le numéro de la dernière ligne vide dans la colonne A.
    i = Range("A65536").End(xlUp).Row + 1
 
    'Boucle sur tous les fichiers du répertoire
    For Each FileItem In SourceFolder.Files
        'Inscrit le nom du fichier dans la cellule
        Cells(i, 1) = FileItem.Name
        'Ajoute un lien hypertexte vers le fichier
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), _
            Address:=FileItem.ParentFolder & "\" & FileItem.Name
 
        'Indique la date de dernière modification
        Cells(i, 2) = FileItem.DateLastModified
 
 
        i = i + 1
    Next FileItem
 
    '--- Appel récursif pour lister les fichier dans les sous-répertoires ---.
    For Each SubFolder In SourceFolder.subfolders
        ListeFichiers SubFolder.Path
    Next SubFolder
 
 Range("a1").Select
 
End Sub

**EricDgn** · 22/07/2020, 15h58

Bonjour,

Quelque chose de ce genre devrait pouvoir vous convenir. Il me parait indispensable d'ouvrir chaque fichier pour pouvoir en analyser le contenu (lignes vides, etc.):

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
Dim kLigneVide As Long, kLigne1 As Long, kLigne2 As Long
 
Sub TestListeFichiers()
    Dim Dossier As String
 
    'Définit le répertoire pour débuter la recherche de fichiers.
    '(Attention à ne pas indiquer un répertoire qu contient trop de sous-dossiers ou de
    'fichiers, sinon le temps de traitement va être très long).
    Dossier = "C:\Users\Desktop\Nouveau dossier(3)"
 
    'Appelle la procédure de recherche des fichiers
    ListeFichiers Dossier
 
    'Ajuste la largeur des colonnes A:E en fonction du contenu des cellules.
    Columns("A:E").AutoFit
    MsgBox "Terminé"
 
End Sub
 
Sub ListeFichiers(Repertoire As String)
    '
    'Nécessite d'activer la référence "Microsoft Scripting RunTime"
        'Dans l'éditeur de macros (Alt+F11):
        'Menu Outils
        'Références
        'Cochez la ligne "Microsoft Scripting RunTime".
        'Cliquez sur le bouton OK pour valider.
 
    Dim Fso As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim SubFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim i As Long
 
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = Fso.GetFolder(Repertoire)
 
 'Mise à zero de la page
    Cells.Select
    Selection.ClearContents
 
 'Titre des colonnes
    Range("a1").Value = "Nom du fichier"
    Range("b1").Value = "Date de modification"
    Range("c1").Value = "Nombre de données fichier"
    Range("d1").Value = "Nombre de Ligne total du fichier"    '-> LE BUT est de pouvoir créer un pourcentage et graphique par la suite
    Range("e1").Value = "Nombre de Ligne contenant un '1'"    '-> LE BUT est de pouvoir créer un pourcentage et graphique par la suite
    Range("f1").Value = "Nombre de Ligne contenant un '2'"    '-> LE BUT est de pouvoir créer un pourcentage et graphique par la suite
 
 'Mise en forme 1er ligne
 
    Rows("1:1").Select
    Selection.Font.Bold = True
    Selection.Font.Size = 12
 
    'feuille vidée, commence à la 2e ligne
    i = 2
 
    'Boucle sur tous les fichiers du répertoire
    For Each FileItem In SourceFolder.Files
        'Inscrit le nom du fichier dans la cellule
        Cells(i, 1) = FileItem.Name
        'Ajoute un lien hypertexte vers le fichier
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), _
            Address:=FileItem.ParentFolder & "\" & FileItem.Name
 
        'Indique la date de dernière modification
        Cells(i, 2) = FileItem.DateLastModified
        AnalyserFichier FileItem.Name
        Cells(i, 3) = kLigneVide
        Cells(i, 4) = kLigne1
        Cells(i, 5) = kLigne2
        i = i + 1
    Next FileItem
    '--- Appel récursif pour lister les fichier dans les sous-répertoires ---.
    For Each SubFolder In SourceFolder.subfolders
        ListeFichiers SubFolder.Path
    Next SubFolder
End Sub
 
Sub AnalyserFichier(sFileName As String)
    Dim kR As Long, s As String
    kLigneVide = 0
    kLigne1 = 0
    kLigne2 = 0
    If Left(sFileName, 4) <> ".asc" Then Exit Sub
    '--- ouvre le fichier pour l'analyser
    Workbooks.OpenText Filename:=sFileName
    kR = Cells(Rows.Count, 1).End(xlUp).Row            '--- n° de la dernière ligne en colonne 1
    While kR > 0
        s = CStr(Cells(kR, 1))
        If Len(s) = 0 Then kLigneVide = kLigneVide + 1
        If InStr(s, "1") Then kLigne1 = kLigne1 + 1
        If InStr(s, "2") Then kLigne2 = kLigne2 + 1
        kR = kR - 1
    Wend
    '--- referme la fenêtre, sans modifier le fichier
    ActiveWindow.Close False
End Sub

A vérifier.
Cordialement.

**Phil Free** · 22/07/2020, 17h02

Bonjour,

@ EricDgn : L'idée est est bonne mais comme le FSO est déjà créé cela peut être fait directement via ce FSO voir cette discussion : https://www.developpez.net/forums/d1.../#post10373722 (voir partie VBscript. Elle est directement utilisable dans VBA)

Cette méthode est normalement plus rapide car elle ne passe pas par une ouverture du fichier.

**EricDgn** · 22/07/2020, 20h33

Bonjour,

Effectivement Phil Free, nettement plus rapide en restant dans FSO!

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
Option Explicit
 
Dim i As Long, kLigneVide As Long, kLigne1 As Long, kLigne2 As Long, kT As Single
 
Sub TestListeFichiers()
    Dim Dossier As String
 
 'Mise à zero de la page
    Cells.Select
    Selection.ClearContents
 
 'Titre des colonnes
    Range("a1").Value = "Nom du fichier"
    Range("b1").Value = "Date de modification"
    Range("c1").Value = "Nombre de données fichier"
    Range("d1").Value = "Nombre de Ligne total du fichier"    '-> LE BUT est de pouvoir créer un pourcentage et graphique par la suite
    Range("e1").Value = "Nombre de Ligne contenant un '1'"    '-> LE BUT est de pouvoir créer un pourcentage et graphique par la suite
    Range("f1").Value = "Nombre de Ligne contenant un '2'"    '-> LE BUT est de pouvoir créer un pourcentage et graphique par la suite
 
 'Mise en forme 1er ligne
 
    Rows("1:1").Select
    Selection.Font.Bold = True
    Selection.Font.Size = 12
 
    'feuille vidée, commence à la 2e ligne
    i = 2
 
    'Définit le répertoire pour débuter la recherche de fichiers.
    '(Attention à ne pas indiquer un répertoire qu contient trop de sous-dossiers ou de
    'fichiers, sinon le temps de traitement va être très long).
    Dossier = "C:\Users\Desktop\Nouveau dossier(3)"
 
    kT = Timer
    'Appelle la procédure de recherche des fichiers
    'ListerFichiers Dossier                  '--- méthode 1
    ListerAnalyserFichiers Dossier          '--- méthode 2
 
    'Ajuste la largeur des colonnes A:E en fonction du contenu des cellules.
    Columns("A:E").AutoFit
    MsgBox "Terminé. Temps mis: " & Int(Timer - kT) & " secondes."
 
End Sub
 
Sub ListerAnalyserFichiers(Repertoire As String)
    'Nécessite d'activer la référence "Microsoft Scripting RunTime"
        'Dans l'éditeur de macros (Alt+F11):
        'Menu Outils
        'Références
        'Cochez la ligne "Microsoft Scripting RunTime".
        'Cliquez sur le bouton OK pour valider.
 
    Dim Fso As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim SubFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim oTxt As Scripting.TextStream
    Dim s As String
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = Fso.GetFolder(Repertoire)
 
    'Boucle sur tous les fichiers du répertoire
    For Each FileItem In SourceFolder.Files
        If Right(FileItem.Name, 4) = ".asc" Then
            'Inscrit le nom du fichier dans la cellule
            Cells(i, 1) = FileItem.Name
            'Ajoute un lien hypertexte vers le fichier
            ActiveSheet.Hyperlinks.Add _
                Anchor:=Cells(i, 1), _
                Address:=FileItem.ParentFolder & "\" & FileItem.Name
            'Indique la date de dernière modification
            Cells(i, 2) = FileItem.DateLastModified
            '--- analyse fichier
            kLigneVide = 0
            kLigne1 = 0
            kLigne2 = 0
            Set oTxt = Fso.OpenTextFile(FileItem, ForReading)
            With oTxt
                While Not .AtEndOfStream
                    s = .Readline
                    s = Trim(s)     '--- utile ?
                    If Len(s) = 0 Then kLigneVide = kLigneVide + 1
                    If InStr(s, "1") > 0 Then kLigne1 = kLigne1 + 1
                    If InStr(s, "2") > 0 Then kLigne2 = kLigne2 + 1
                Wend
            End With
            oTxt.Close
            Cells(i, 3) = kLigneVide
            Cells(i, 4) = kLigne1
            Cells(i, 5) = kLigne2
            i = i + 1
        End If
    Next FileItem
    '--- Appel récursif pour lister les fichier dans les sous-répertoires ---.
    For Each SubFolder In SourceFolder.SubFolders
        ListerAnalyserFichiers SubFolder.Path
        DoEvents    '--- permet un ctrl-break
    Next SubFolder
End Sub