Boucler dans un répertoire

Le 09/04/2016 à 18:03

Bonjour le forum

J'ai besoin d'appliquer un code dans un répertoire sur des documents *.txt de chaque sous-répertoire de celui-ci.

Peut-on extraire dans un nouveau dossier tous les fichiers *txt d'un répertoire et de ses sous dossiers ?

Bien sur à chaque fois le nom du répertoire est différent, les sous répertoires aussi, et le fichier *.txt aussi

D'avance je vous remercie pour votre aide et votre disponibilité

Le 09/04/2016 à 21:25

Bonsoir Eole, bonsoir le forum,

Le code ci-dessous scrute un dossier et tous ses sous-dossiers (1er degré) mais ne va pas au-delà du premier degré. Il n'analyse pas le sous-dossier d'un sous-dossier. Cela conviendra-t-il ?...

Le résultat est renvoyé dans un tableau à partir de la ligne 1 dans les colonnes A (non du dossier / sous-dossier) et B (nom du fichier) :

Sub Macro1()
Dim CI As String 'définit le Chemin d'accès du dossier Initial
Dim SF As Object 'déclare la variable SF (Système de Fichiers)
Dim DI As Object 'déclare la variable DI (Dossier Initial)
Dim I As Integer 'déclare la variable I (Incrément)
Dim F As Object 'déclare la variable F (Fichier)
Dim TF() 'déclare la variable TF (Tableau des Fichiers)
Dim SD As Object 'déclare la variable SD (Sous-Dossiers)

CI = "C:\Users\eole33\Documents" 'définit le chemin du dossier initial (à adapter)
Set SF = CreateObject("Scripting.FileSystemObject") 'définit le système de fichier SF
Set DI = SF.GetFolder(CI) 'définit le dossier initial
I = 1 'initialise la variable I
For Each F In DI.Files 'boucle sur tous les fichiers F du dossier intial DI
    If Right(F.Name, 3) = "txt" Then 'condition : si les 3 derniers caractères du nom du fichier F sont "txt"
        ReDim Preserve TF(1 To 2, 1 To I) 'redimensionne le tableau des fichiers TF (2 lignes, I colonnes)
        TF(1, I) = DI.Name 'récupère le nom du dossier dans la ligne 1
        TF(2, I) = F.Name 'récupère le nom du fichier dans la ligne 2
        I = I + 1 'incrémente I (ajoute une colonne au tableau de fichiers TF)
    End If 'fin de la condition
Next F 'prochain fichier de la boucle
For Each SD In DI.SubFolders 'boucle 1 : sur tous les sous-dossiers du dossier initial DI
    For Each F In SD.Files 'boucle 2 : sur tous les fichiers du sous-dossier
        If Right(F.Name, 3) = "txt" Then 'condition : si les 3 derniers caractères du nom du fichier F sont "txt"
            ReDim Preserve TF(1 To 2, 1 To I) 'redimensionne le tableau des fichiers TF (2 lignes, I colonnes)
            TF(1, I) = DI.Name & "\" & SD.Name 'récupère le nom du sous-dossier dans la ligne 1
            TF(2, I) = F.Name 'récupère le nom du fichier dans la ligne 2
            I = I + 1 'incrémente I (ajoute une colonne au tableau de fichiers TF)
        End If 'fin de la condition
    Next F 'prochain fichier de la boucle 2
Next SD 'prochain sous-dossier de la boucle 1
If I > 1 Then 'condition : si au moins un fichier a été trouvé
    'renvoie dans la cellule A1 redimensionnée (autant de lignes que TF as de colonne, 2 colonnes) le tableau TF transposé
    Range("A1").Resize(UBound(TF, 2), UBound(TF, 1)).Value = Application.Transpose(TF)
End If 'fin de la condition
End Sub
Le 10/04/2016 à 09:41

Bonjour le forum,

Bonjour ThauThème, merci pour ton aide et pour ce code

Alors ce code permet de lister dans une feuille excel les noms des sous-répertoire et les fichiers *.txt contenu dans chaqu'un d'eux.

dans mon cas il n'y a toujours qu'un seul fichier *.txt contenu dans le sous répertoire et il s'appele "fiber_info_otdr.txt", par contre chaque sous dossier à un nom différent.

Est-il possible que ce code, au lieu qu'il liste dans une feuille excel les sous-répertoires et les fichiers *.txt, renomme directement les fichiers*.txt par le nom de son sous-répertoire et que tous les fichiers ainsi renommer soient rassemblés dans un nouveau sous-répertoire tout en gardant les fichiers *.txt originaux dans chaqu'un de leur sous-répertoire?

j'aimerai bien mettre en pièces jointes un dossier mais ça ne passera jamais y aurait-il une solution pour que je mette enligne un dossier modèle?

Le 10/04/2016 à 12:46

Bonjour,

une proposition qui boucle sur tous les répertoires et sous-répertoires et fait la copie vers un répertoire de destination.

Sub listffolder()
    Dim a(1 To 10000) 'max 10000 fichiers sélectionnés
    sr = "f:\srtest\" 'répertoire de destination (doit exister)
    listfolder "F:\", "*.txt", a, n
    Range("A1").Resize(n) = Application.Transpose(a)
    For i = 1 To 10000
    If a(i) = "" Then Exit For
    nf = Replace(Replace(a(i), "\", "_"), ":", "")
    FileCopy a(i), sr & nf
    Next i
End Sub

Sub listfolder(folder, filtre, ByRef a, ByRef n)

    Set fold = CreateObject("Scripting.FileSystemObject").GetFolder(folder)
    For Each f In fold.SubFolders
        If Right(f, 1) <> "\" Then listfolder f & "\", filtre, a, n Else listfolder f, filtre, a, n
    Next
    For Each f In fold.Files
        If Right(f, 4) Like filtre Then
            n = n + 1
            a(n) = folder & f.Name
        End If
    Next
End Sub
Le 10/04/2016 à 13:38

Bonjour h2so4

Merci de te pencher sur mon souci

j'ai pris le code que tu as mis en ligne

en ligne 3 j'ai mis :

sr = "C:\Users\eole33\Documents\nv" 'répertoire de destination (doit exister)

en ligne 4 j'ai mis :

listfolder "C:\Users\eole33\Documents", "*.txt", a, n

et lorsque je lance la macro, elle plante en ligne 9

FileCopy a(i), sr & nf)

en me disant "erreur d'exécution '75', erreur d'accès chemin/Fichier

je ne comprends pas

Le 10/04/2016 à 13:52

bonjour,

remplace

sr = "C:\Users\eole33\Documents\nv" 'répertoire de destination (doit exister)

par

sr = "C:\Users\eole33\Documents\nv\" 'répertoire de destination (doit exister)
Le 10/04/2016 à 14:25

ça ne fonctionne toujours pas

Le 10/04/2016 à 14:38

et remplace

listfolder "C:\Users\eole33\Documents", "*.txt", a, n

par

listfolder "C:\Users\eole33\Documents\", "*.txt", a, n
Le 10/04/2016 à 14:55

Pareil même message

Le 10/04/2016 à 16:12
eole-33 a écrit :

Pareil même message

bonjour

ajoute l'instruction juste avant l'instruction filecopy

msgbox a(i) & ", " & sr & nf

et mets-nous le résultat

Le 10/04/2016 à 16:53

Voici le résultat

C:\Users\eole33\Documents\PB PT 003217\fiber_info_otdr.txt,

C:\Users\eole33\Documents\nv\C_Users_eole33_Documents_PB PT 003217_fiber_info_otdr.txt

A la vue du résultat je pense qu'il faut que j'apporte des précisions sur ce que je cherche à faire, même si ce n'est pas ce que j'ai demandé.

Supposons la structure suivante :

|-toto

| -TEST.txt

|-titi

|-TEST.txt

|-tata

|-TEST.tt

|...

Je voudrais que chaque fichier porte le nom du répertoire parent et donc obtenir ceci :

|-toto

| toto.txt

|-titi

|-titi.txt

|-tata

|-tata.txt

|...

et donc en fait boucler dans un répertoire que je choisis avec une boite de dialogue.

je m'excuse si ce n'était pas précisée au début

Le 10/04/2016 à 17:31

bonjour,

à tester

Sub listffolder()
    Dim a(1 To 10000) 'max 10000 fichiers sélectionnés
   sr = "f:\srtest\" 'répertoire de destination (doit exister)
   rep = "g:\" ' répertoire à examiner
   listfolder rep, "*.txt", a, n
   Range("A1").Resize(n) = Application.Transpose(a)
    For i = 1 To 10000
    If a(i) = "" Then Exit For
    s = InStrRev(a(i), "\")
    nf = Left(a(i), s - 1) & ".txt"
    s = InStrRev(nf, "\")
    nf = Mid(nf, s + 1)
    Cells(i, 2) = nf
    FileCopy a(i), sr & nf
    Next i
End Sub

Sub listfolder(folder, filtre, ByRef a, ByRef n)

    Set fold = CreateObject("Scripting.FileSystemObject").GetFolder(folder)
    For Each f In fold.SubFolders
        If Right(f, 1) <> "\" Then listfolder f & "\", filtre, a, n Else listfolder f, filtre, a, n
    Next
    For Each f In fold.Files
        If Right(f, 4) Like filtre Then
            n = n + 1
            a(n) = folder & f.Name
        End If
    Next
End Sub
Le 10/04/2016 à 17:57

Merci pour ton aide H2so4,

mais ça beug à la ligne 5

Erreur d'exécution '1004': erreur définie par l'application ou par l'objet

Le 10/04/2016 à 18:07
Sub listffolder()
    Dim a(1 To 10000) 'max 10000 fichiers sélectionnés
  sr = "f:\srtest\" 'répertoire de destination (doit exister)
  rep = "g:\" ' répertoire à examiner
  listfolder rep, "*.txt", a, n
if n=0 then msgbox " pas de fichier trouvé":exit sub
   Range("A1").Resize(n) = Application.Transpose(a)
    For i = 1 To 10000
    If a(i) = "" Then Exit For
    s = InStrRev(a(i), "\")
    nf = Left(a(i), s - 1) & ".txt"
    s = InStrRev(nf, "\")
    nf = Mid(nf, s + 1)
    Cells(i, 2) = nf
    FileCopy a(i), sr & nf
    Next i
End Sub

Sub listfolder(folder, filtre, ByRef a, ByRef n)

    Set fold = CreateObject("Scripting.FileSystemObject").GetFolder(folder)
    For Each f In fold.SubFolders
        If Right(f, 1) <> "\" Then listfolder f & "\", filtre, a, n Else listfolder f, filtre, a, n
    Next
    For Each f In fold.Files
        If Right(f, 4) Like filtre Then
            n = n + 1
            a(n) = folder & f.Name
        End If
    Next
End Sub
Le 10/04/2016 à 18:27

Erreur 1004 résolu, par contre toujours le même souci avec la ligne

 FileCopy a(i), sr & nf

Changement dans feuille excel, j'ai le bon nom qui se créé mais juste dans la cellule B1

pas de fichier dans le répertoire de destination

Avec la ligne MsgBox comme tout à l'heure :

C:\Users\eole33\Documents\PB PT 003217\fiber_info_otdr.txt

C:\Users\eole33\Documents\PB\nv PT 003217.txt

Le 10/04/2016 à 22:22
eole-33 a écrit :

Erreur 1004 résolu, par contre toujours le même souci avec la ligne

 FileCopy a(i), sr & nf

Changement dans feuille excel, j'ai le bon nom qui se créé mais juste dans la cellule B1

pas de fichier dans le répertoire de destination

Avec la ligne MsgBox comme tout à l'heure :

C:\Users\eole33\Documents\PB PT 003217\fiber_info_otdr.txt

C:\Users\eole33\Documents\PB\nv PT 003217.txt

je suppose que le nom de fichier généré est

C:\Users\eole33\Documents\nv\PB PT 003217.txt

comme indiqué dans le commentaire la macro suppose l'existence du répertoire de destination.

Le 11/04/2016 à 00:15

si tu parle du du nom généré dans la feuille excel, c'est juste PB PT003217.xls

Le 11/04/2016 à 13:51
h2so4 a écrit :
eole-33 a écrit :

Erreur 1004 résolu, par contre toujours le même souci avec la ligne

 FileCopy a(i), sr & nf

Changement dans feuille excel, j'ai le bon nom qui se créé mais juste dans la cellule B1

pas de fichier dans le répertoire de destination

Avec la ligne MsgBox comme tout à l'heure :

C:\Users\eole33\Documents\PB PT 003217\fiber_info_otdr.txt

C:\Users\eole33\Documents\PB\nv PT 003217.txt

je suppose que le nom de fichier généré est

C:\Users\eole33\Documents\nv\PB PT 003217.txt

et non

C:\Users\eole33\Documents\PB\nv PT 003217.txt

comme indiqué dans le commentaire la macro suppose l'existence du répertoire de destination.

cette dernière phrase est importante le répertoire

"C:\Users\eole33\Documents\nv\" doit exister pour que la macro fonctionne correctement

Le 11/04/2016 à 17:56

Bonjour le forum

Bonjour h2so4

Ha ok oui c'est bien ce qui était marqué dans la message box, c'est moi qui est oublié le "\" en recopiant

Rechercher des sujets similaires à "boucler repertoire"