Macro lecture répertoires

**maryblu** · 10/09/2018, 14h28

Bonjour

j'ai essayé de compiler une macro (en rabibochant des bouts de codes trouvés par-ci par-là) pour aller récupérer le contenu de fichiers sur un répertoire
Ca n'était peut-être pas très optimisé mais jusque là elle fonctionnait

Là où je coince c'est pour l'adapter pour ne plus seulement lire les fichiers de mon répertoire mais aussi ceux dans des répertoires qui sont dans mon répertoire source

si quelqu'un pouvait passer sur mes macros pour m'aider ce serait vrmt super sympa
J'enverrai le code par mp pour pas rendre le post illisible à la limite

Merci bcp

Mary

**Menhir** · 10/09/2018, 15h23

Envoyé par maryblu

Là où je coince c'est pour l'adapter pour ne plus seulement lire les fichiers de mon répertoire mais aussi ceux dans des répertoires qui sont dans mon répertoire source

Regarder ceci dans la FAQ :
https://excel.developpez.com/faq/?pa...riptingRuntime
https://excel.developpez.com/sources...scenceDossiers

J'enverrai le code par mp pour pas rendre le post illisible à la limite

Si le code est à l'intérieur de balises CODE (bouton # de l'éditeur), il ne rend pas le post illisible.

Invité · 10/09/2018, 15h55

Bonjour,

J'enverrai le code par mp pour pas rendre le post illisible à la limite

mauvaise idée, comme le préconise Menhir (

) utilise la balise {#}.

**maryblu** · 11/09/2018, 11h44

oki j'espère que ce sera pas trop long à visualiser pour pas piquer les yeux

voici le code qui marche

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
 
 
Sub Liste()
    Dim Fichier As String, chemin As String
    Dim i As Long
    Dim rg As Range
 
    'Répertoire contenant les fichiers
    chemin = InputBox("Entrez le chemin du dossier contenant les fichiers")
 
    Fichier = Dir(chemin & "\*.tsv", vbNormal)
 
    'Boucle sur les fichiers
    Do While Fichier <> ""
 
        i = Range("B65536").End(xlUp).Row + 1
 
        ImportText chemin & "\" & Fichier, Cells(i, 2)
 
        Set rg = Sheets("DATA").Cells(i, 2)
        Do Until IsEmpty(rg)
            rg.Offset(0, -1) = Fichier
            Set rg = rg.Offset(1, 0)
        Loop
 
        Cells(i, 1) = "Titre"
 
        Fichier = Dir
 
    Loop
 
   'Mise en forme
 
   Range("a1:a65536").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 
   Supptitre
 
   Split
 
End Sub
 
Sub ImportText(NomFichier As Variant, Cible As Range)
 
    Dim QT As QueryTable
 
    Set QT = ActiveSheet.QueryTables.Add(Connection:="TEXT;" & _
        NomFichier, Destination:=Cible)
 
 
    With QT
        'Définit les séparateur de colonnes dans le fichier txt
        .TextFileOtherDelimiter = Chr(9)
        .TextFileSemicolonDelimiter = True
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .Refresh
 
    End With
 
End Sub

et voila le code quand j'essaye de l'adapter mais qui ne foncitionne pas

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
 
 
Sub TestListeFichiers()
    Dim Dossier As String
 
    'Définit le répertoire pour débuter la recherche de fichiers.
 
    Dossier = "C:\Users\EEL053\Desktop\labo"
 
    'Appelle la procédure de recherche des fichiers
    ListeFichiers Dossier
 
    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
    Dim rg As Range
 
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = Fso.GetFolder(Repertoire)
 
 
    'Boucle sur tous les fichiers du répertoire
    For Each FileItem In SourceFolder.Files
 
        'Boucle sur les fichiers
            Do While FileItem <> ""
 
        i = Range("B65536").End(xlUp).Row + 1
 
        ImportText Repertoire & "\" & FileItem, Cells(i, 2)
 
        Set rg = Sheets("DATA").Cells(i, 2)
        Do Until IsEmpty(rg)
            rg.Offset(0, -1) = FileItem
            Set rg = rg.Offset(1, 0)
        Loop
 
        Cells(i, 1) = "Titre"
 
 
        Loop
 
        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
 
   '--- Mise en forme ---
 
   Range("a1:a65536").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 
   Supptitre
 
   Split
 
 
End Sub
 
 
Sub ImportText(NomFichier As Variant, Cible As Range)
 
    Dim QT As QueryTable
 
    Set QT = ActiveSheet.QueryTables.Add(Connection:="TEXT;" & _
        NomFichier, Destination:=Cible)
 
 
    With QT
        'Définit les séparateur de colonnes dans le fichier txt
        .TextFileOtherDelimiter = Chr(9)
        .TextFileSemicolonDelimiter = True
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .Refresh
 
    End With
 
End Sub