Macro lecture répertoires

Version imprimable

10/09/2018, 14h28
maryblu

Macro lecture répertoires

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
10/09/2018, 15h23
Menhir

Citation:

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

Citation:

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.
10/09/2018, 15h55
Invité

Bonjour,

Citation:

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

mauvaise idée, comme le préconise Menhir (:coucou:) utilise la balise {#}.

codes

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

voici le code qui marche

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
 
 
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:

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

Merci de votre aide et de votre temps :)

Mary

11/09/2018, 12h58
kiki29
Salut, à titre d'information voir :
19/09/2018, 08h27
maryblu

Bonjour tout le monde
désolée j'ai eu pas mal de boulot à coté de ce pti fichier que je dois faire :(
merci pour les liens :) j'ai zieuté un peu mais je comprends pas gd chose :(
j'espère que qqn verra ce qui coince dans mon bout de code :/
Bonne journée à tous
Mary
19/09/2018, 09h01
Menhir

Relancer une discussion sans apporter de nouvelles informations, ça ne sert pas à grand chose... :?
19/09/2018, 09h15
maryblu

Dsl je voulais au moins remercier KKI29 pour sa réponse et indiquer que j'avais pris le tps de consulter ses liens meme si je n'avais pas compris et pas pu les utiliser...