Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2010 Copier un fichiers txt qui ont le même nom de plusieurs sous-dossiers vers un dossier

hamzaelhathout

XLDnaute Nouveau
Bonjour,

J'ai un dossier qui contiens plusieurs sous-dossier pour chaque journée qui ont pour nom "aaaa-mm-jj".
Dans ces sous-dossier, il y a un rapport au format txt qui a toujours le même nom "XXXXX.txt"

Je voudrais créer une macro qui aille chercher ce fichier txt dans chaque sous dossier et me le copie avec comme nom, celui du sous dossier dans lequel il se trouve (donc aaaa-mm-jj.txt) vers un dossier "destination".

J'ai cherché dans le forum mais je n'ai pas trouvé exactement ça.

Merci d'avance.
 
Solution
Super merci.

J'ai adapté pour le nom du fichier exact.

VB:
Option Explicit

Sub Test()
    Call FichiersSousRépertoires("C:\Users\Youssef\Documents\fansub\testmacro\")
End Sub

'---------------------------------------------
'Fichiers des sous-répertoires d'un répertoire
'---------------------------------------------
Sub FichiersSousRépertoires(NomRépertoire As String)
    Dim oFSO As Object
    Dim oDir As Object
    Dim oSubDir As Object
    Dim oFile As Object

    'File System Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")

    'Directory Object
    Set oDir = oFSO.GetFolder(NomRépertoire)

    'Parcours des sous-répertoires du répertoire
    For Each oSubDir In oDir.SubFolders
        'Parcours des fichiers du...

Dudu2

XLDnaute Barbatruc
Ok le \\ c'est parce que j'ai passé "H:\" en argument.
Pour le FSO c'et différent si on passe "H:" ou "H:\".
Par contre tu n'as pas répondu au problème du post #27.

Voilà la correction pour le scan FSO.
 

Pièces jointes

  • ListesFichiersRépertoire.xlsm
    25.8 KB · Affichages: 5

patricktoulon

XLDnaute Barbatruc
ma fois en evitant les recycle et tout dossier system cachés ou pas
j'arrive au meme résultat que mon dir récursif 4591 fichier
le .webm" en effet n'est pas choppé avec dir 4590 fichier
pour le fso sur disque complet
VB:
Sub test()
    Dim racine$
    racine = "H:"
    tableau = recherche_récursive(racine)
    Cells(1, 1).Resize(UBound(tableau) + 1, 1) = Application.Transpose(tableau)
End Sub
'
'
Private Function recherche_récursive(dparent, Optional L As String) As Variant
    Dim FSO As Object, Lparent As Object, SubFolder As Object, Ficher
    Set FSO = CreateObject("scripting.filesystemobject")    ' on declare l'object
    ' regard sur les fichiers
    Set Lparent = FSO.GetFolder(dparent)    'on attribue a l'object.getfolder le dossier demandé 'Scripting.Folder
      '-------------------------------------------------------------
     'condition garde fou pour fichier ou dossiers non autorisé
    If Not Lparent Like "*RECYCLE.*" And Not Lparent Like "BIN\" And Not Lparent Like "*System Volume Information*" Then
     '----------------------------------------------------------------
        For Each Ficher In Lparent.Files    'on boucle sur les fichiers qui sont dans ce dossier
            L = L & Ficher & vbCrLf
        Next
        'boucles sur les sous dossiers
        For Each SubFolder In Lparent.SubFolders    'on boucle sur les dossiers qui sont dans ce dossiers
            'L = L & SubFolder.Path & vbCrLf
            recherche_récursive SubFolder.Path, L   ' on rappelle la fonction avec pour argument le chemin du sous dossier ainsi que l'extension et L qui est déjà peut être remplie
        Next SubFolder
    End If

    recherche_récursive = Split(L, vbCrLf)    'on coupe la liste par les saut de lignes on a maintenant un array la fonction devient cet array
End Function
mais bon là ou je met (avec dir )0.264568 secondes fso met 7 secondes alors quand je disais minimum 10 fois plus rapide c'est un euphémisme
 

Dudu2

XLDnaute Barbatruc
Le webm n'est pas choppé parce que le GetAttr se plante dessus à cause de l'accent circonflexe qui est séparé du i par le Dir(). Et là je sais pas ce qu'il faut faire.
Sur mes tests j'ai toujours un rapport de 1 à 5 ou 1 à 6. Jamais 1 à 30.
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
tiens @Dudu2 j'ai réécrit la fonction avec un array dynamique et plus un split
on gagne un peu en n'ayant pas de transmission final (fonction/sub) ,(l'array étant pré existant )
VB:
Sub test()
    Dim racine$, tim
    ReDim t(1 To 1)    'on dimentionne un array de 1 item pour commencer
    racine = "H:"    ' disque à lister
    tim = Timer
    recherche_récursive racine, t    'appel de la fonction t est injecté comme tel
    MsgBox (Timer - tim) & " secondes ; " & UBound(t) & " fichiers"
    Cells(1, 1).Resize(UBound(t), 1) = Application.Transpose(t)
End Sub
'
'
Private Function recherche_récursive(dparent, t, Optional L As String)    ' As Variant
    Dim FSO As Object, Lparent As Object, SubFolder As Object, Ficher, a
    Set FSO = CreateObject("scripting.filesystemobject")    ' on declare l'object
    Set Lparent = FSO.GetFolder(dparent)  ' regard sur les fichiers  'on attribue a l'object.getfolder le dossier demandé 'Scripting.Folder
    '-------------------------------------------------------------
    'condition garde fou pour fichier ou dossiers non autorisé
    If Not Lparent Like "*RECYCLE.*" And Not Lparent Like "BIN\" And Not Lparent Like "*System Volume Information*" Then
        '----------------------------------------------------------------
        For Each Ficher In Lparent.Files    'on boucle sur les fichiers qui sont dans ce dossier
            a = UBound(t) + 1: ReDim Preserve t(1 To a): t(a) = Ficher    ' on redim preserve le tableau(t) avec un item de plus et on instruit l'item avec le chemin de fichier trouvé
        Next
        For Each SubFolder In Lparent.SubFolders    'on boucle sur les dossiers qui sont dans ce dossiers
            'a = UBound(t) + 1: ReDim Preserve t(1 To a): t(a) = SubFolder.Path 'SI ON LISTE AUSSI LES DOSSIERS , on redim preserve le tableau(t) avec un item de plus et on instruit l'item avec le chemin de dossier trouvé
            recherche_récursive SubFolder.Path, t, L  ' on rappelle la fonction avec pour argument le chemin du sous dossier ainsi que le tableau(t) pour continuer a l'instruire
        Next SubFolder
    End If
  End Function
 

Dudu2

XLDnaute Barbatruc
Quand même on est français Môssieur ! On accentue.
D'ailleurs ce fichier je l'ai récupéré de YouTube je crois. Donc rien d'extraordinaire.

Y a un solution qui consiste à récupérer l'erreur du GetAttr() et de faire des Replace() à condition d'identifier les cas où ça se produit => un assez gros boulot d'investigation des lettres accentuées candidates à l'erreur. Faut toutes les essayer, et sans doute pas seulement les françaises ("ÀÂÉÈÊÎÔÙÛÇàâéèêîôùûç").
 

patricktoulon

XLDnaute Barbatruc
re

Quand même on est français Môssieur ! On accentue.
et ben m'enfou voilà!!!
dans le nom d'un fichier ça n'a pas de sens
et en réponse au #43 on peut pas gérer puisque le dir ne ramène rien donc pour le replace heu.. walouh!!!


juste une parenthèse
une autre raison que je préfère dir c'est qu'avec fso pour lister par exemple les fichiers avec une extension précise il liste quand même tout l'arborescence a l'inverse de dir qui peut etre exclusif
c'est d'ailleurs pour ça qu'il est plus long

regarde teste ces deux fso tu va voir la recherche exclusive dure a peine un peu plus longtemps mais tout de même


VB:
Sub testQ()
    Dim racine$, tim
    ReDim t(1 To 1)    'on dimentionne un array de 1 item pour commencer
    racine = "H:"    ' disque à lister
    tim = Timer
    recherche_récursive racine, t    'appel de la fonction t est injecté comme tel
    MsgBox (Timer - tim) & " secondes ; " & UBound(t) & " fichiers"
    Cells(1, 1).Resize(UBound(t), 1) = Application.Transpose(t)
End Sub
'
'
Private Function recherche_récursive(dparent, t, Optional L As String)    ' As Variant
    Dim FSO As Object, Lparent As Object, SubFolder As Object, Ficher, a
    Set FSO = CreateObject("scripting.filesystemobject")    ' on declare l'object
    Set Lparent = FSO.GetFolder(dparent)  ' regard sur les fichiers  'on attribue a l'object.getfolder le dossier demandé 'Scripting.Folder
    '-------------------------------------------------------------
    'condition garde fou pour fichier ou dossiers non autorisé
    If Not Lparent Like "*RECYCLE.*" And Not Lparent Like "BIN\" And Not Lparent Like "*System Volume Information*" Then
        '----------------------------------------------------------------
        For Each Ficher In Lparent.Files    'on boucle sur les fichiers qui sont dans ce dossier
            a = UBound(t) + 1: ReDim Preserve t(1 To a): t(a) = Ficher    ' on redim preserve le tableau(t) avec un item de plus et on instruit l'item avec le chemin de fichier trouvé
        Next
        For Each SubFolder In Lparent.SubFolders    'on boucle sur les dossiers qui sont dans ce dossiers
            'a = UBound(t) + 1: ReDim Preserve t(1 To a): t(a) = SubFolder.Path 'SI ON LISTE AUSSI LES DOSSIERS , on redim preserve le tableau(t) avec un item de plus et on instruit l'item avec le chemin de dossier trouvé
            recherche_récursive SubFolder.Path, t, L  ' on rappelle la fonction avec pour argument le chemin du sous dossier ainsi que le tableau(t) pour continuer a l'instruire
        Next SubFolder
    End If
    'recherche_récursive = t   'a la fin la fonction devient le tableau (t)
End Function


'--------------------------------------------------------
Sub testzzzzz()
    Dim racine$, tim
    ReDim t(1 To 1)    'on dimentionne un array de 1 item pour commencer
    racine = "H:"    ' disque à lister
    tim = Timer
    recherche_récursive2 racine, t, ".txt"   'appel de la fonction t est injecté comme tel
    MsgBox (Timer - tim) & " secondes ; " & UBound(t) & " fichiers"
    Cells(1, 1).Resize(UBound(t), 1) = Application.Transpose(t)
End Sub
'
'
Private Function recherche_récursive2(dparent, t, Optional ext As String = "*")  ' As Variant
    Dim FSO As Object, Lparent As Object, SubFolder As Object, Ficher, a
    Set FSO = CreateObject("scripting.filesystemobject")    ' on declare l'object
    Set Lparent = FSO.GetFolder(dparent)  ' regard sur les fichiers  'on attribue a l'object.getfolder le dossier demandé 'Scripting.Folder
    '-------------------------------------------------------------
    'condition garde fou pour fichier ou dossiers non autorisé
    If Not Lparent Like "*RECYCLE.*" And Not Lparent Like "BIN\" And Not Lparent Like "*System Volume Information*" Then
        '----------------------------------------------------------------
        For Each Ficher In Lparent.Files    'on boucle sur les fichiers qui sont dans ce dossier
           If Right(Ficher, Len(ext)) Like ext Then a = UBound(t) + 1: ReDim Preserve t(1 To a): t(a) = Ficher    ' on redim preserve le tableau(t) avec un item de plus et on instruit l'item avec le chemin de fichier trouvé
        Next
        For Each SubFolder In Lparent.SubFolders    'on boucle sur les dossiers qui sont dans ce dossiers
            'a = UBound(t) + 1: ReDim Preserve t(1 To a): t(a) = SubFolder.Path 'SI ON LISTE AUSSI LES DOSSIERS , on redim preserve le tableau(t) avec un item de plus et on instruit l'item avec le chemin de dossier trouvé
            recherche_récursive SubFolder.Path, t, ext  ' on rappelle la fonction avec pour argument le chemin du sous dossier ainsi que le tableau(t) pour continuer a l'instruire
        Next SubFolder
    End If
    'recherche_récursive = t   'a la fin la fonction devient le tableau (t)
End Function
 

Dudu2

XLDnaute Barbatruc
Je sais bien que Dir() est bien plus rapide mais il y a ce problème qui est d'ailleurs plus complexe qu'il n'y parait car j'ai nommé un fichier "@@@ÀÂÉÈÊÎÔÙÛÇàâéèêîôùûç.txt" et ça passe !!!

Donc c'est un gros bug Excel dont les conditions d'apparition sont difficile à trouver et donc difficile à contourner. Je ne vais pas me lancer là-dedans.
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…