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

hamzaelhathout · 3 Février 2021

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.

hamzaelhathout · 3 Février 2021

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 · 7 Février 2021

Pour Transposer j'utilise ces fonctions persos dont l'une (TransposeExcel) reproduit le comportement Excel de réduction ou ajout de dimension et l'autre (TransposeNaturel) reste neutre sur les dimensions d'origine.

Dudu2 · 7 Février 2021

Chez moi la version 2 semble 1/100ème plus rapide.
J'ai 3000 fichiers en H:

Pour ce qui concerne mon fichier comparatif et les Modules de code correspondants à chaque méthode, j'ai mis la dernière version toujours en Post #72.

patricktoulon · 7 Février 2021

ok donc je fait pareil j'utilise (si dimension 1)

il faudrait que l'on puisse déterminer quand le dernier appel récursif se produit
sinon c'est dans la sub d’appel que ça va se passer
étonnant chez moi c'est le contraire la 1 avec le test like recycle va plus vite que le shunt error et a chaque fois
et oui c'est bien 0.1XXX la différence
Edit:
par contre quand je liste toute extension c'est la 2 la plus rapide

patricktoulon · 7 Février 2021

et pour la méthode cmd il faudrait pouvoir exclure les recycle
Commande = "chcp 1252 > nul" & vbCrLf & "dir " & Racine(avec exclusion) & " /S /B /O " & doss & " >" & fichier

Dudu2 · 7 Février 2021

Il faut surtout que tu puisses différencier le 1er appel (qui doit donner la valeur de retour) et les appels récursifs (dont la valeur de retour n'a pas à être valorisée).
Le dernier appel récursif tu t'en fiches.

Pour ça tu peux utilise le 1er argument: dparent (as variant)

VB:

If Typeof dparent Is Object  Then
    'Appel récursif'
    Set Lparent = dparent
Else
    'Appel initial'
    Set Lparent = FSO.GetFolder(dparent)
end if

Et quand tu généres un appel récursif tu ne passes pas le chemin String mais l'objet SubFolder

Code:

Then recherche_récursive SubFolder, t, E, True

Mais toi tu t'en fiches parce que tu passes la Table en argument.
Mais si tu avais un traitement spécial pour l'appel initial tu peux faire ça.

patricktoulon · 7 Février 2021

re j'avoue ne pas comprendre ton if else

le premier je le détermine déjà avec recall que la sub d'appel n'injecte pas (il est donc false par défaut)

c'est le dernier qui faudrait

Dudu2 · 7 Février 2021

Ok c'est vrai, tu as un argument spécial pour identifier un appel récursif.
Si tu appliques la méthode décrite ci-dessus, il devient inutile. Mais bon tu fais comme tu préfères
Sinon je vois pas pourquoi tu veux identifier le dernier appel récursif (ce qui à mon avis est impossible).

Il faut bien voir qu'avec les appels récursifs, le 1er appel est aussi le dernier Exit de la fonction.
C'est comme les poupées russes.

Dudu2 · 7 Février 2021

VB:

Private Function recherche_récursive(dparent, t, Optional E As String = "*.*") ' As Variant
    Static FSO As Object
    Dim Lparent As Object, SubFolder As Object, Fichier

    If TypeOf dparent Is Object  Then
        'Appel récursif'
        Set Lparent = dparent
    Else
        'Appel initial'
        Set FSO = CreateObject("scripting.filesystemobject") ' on declare l'object
        Set Lparent = FSO.GetFolder(dparent)
    End If

    If Dir(Lparent.Path & "\" & E) <> "" Then
        For Each Fichier In Lparent.Files    'on boucle sur les fichiers qui sont dans ce dossier
            If Mid(Fichier, InStrRev(Fichier, "\")) Like E Then ReDim Preserve t(UBound(t) + 1): t(UBound(t) - 1) = Fichier:    ' on redim preserve le tableau(t) avec un item de plus et on instruit l'item avec le chemin de fichier trouvé
        Next
    End If
    'If Lparent.subfolders.Count Then
        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é
            On Error Resume Next    '  pour gérer les dossier interdits
            'si il y a des fichiers correspondant a la recherche ou si il y a encore un/des sousdossiers dans ce subfolder on relance
            If Dir(SubFolder.Path & "\" & E) <> "" And Not SubFolder.Path Like "*RECYCLE*" Or SubFolder.subfolders.Count > 0 Then recherche_récursive SubFolder, t, E                ' on rappelle la fonction avec pour argument le chemin du sous dossier ainsi que le tableau(t) pour continuer a l'instruire et le part of (nom/ext)
            Err.Clear
        Next SubFolder
    'End If
End Function

patricktoulon · 7 Février 2021

ben je veux l'identifier pour faire ma boucle de transpose

a d'accords tu fait sauter la variable recall
je perd un peu avec le if else 0.05 pour le disque entier 5560 fichiers

non je pensais faire un truc comme ça regarde

VB:

Private Function recherche_récursive(dparent, t, Optional E As String = "*.*", Optional recall As Boolean = False, Optional foldercount As Long = 0)    ' As Variant
    Static FSO As Object
    Dim Lparent As Object, SubFolder As Object, Ficher

    If Not recall Then 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
  
    foldercount = foldercount - 1    ' on examine le dossier alors on enleve 1 au count
    foldercount = foldercount + Lparent.subfolders.Count    ' et on rajoute le subfolders.count
  
    If Dir(Lparent.Path & "\" & E) <> "" Then
        For Each Ficher In Lparent.Files    'on boucle sur les fichiers qui sont dans ce dossier
            If Mid(Ficher, InStrRev(Ficher, "\")) Like E Then ReDim Preserve t(UBound(t) + 1): t(UBound(t) - 1) = Ficher:    ' on redim preserve le tableau(t) avec un item de plus et on instruit l'item avec le chemin de fichier trouvé
        Next
    End If
    'If Lparent.subfolders.Count Then
    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é

        On Error Resume Next    '  pour gérer les dossier interdits
        'si il y a des fichiers correspondant a la recherche ou si il y a encore un/des sousdossiers dans ce subfolder on relance
        If Dir(SubFolder.Path & "\" & E) <> "" And Not SubFolder.Path Like "*RECYCLE*" Or SubFolder.subfolders.Count > 0 Then recherche_récursive SubFolder.Path, t, E, True, foldercount                 ' on rappelle la fonction avec pour argument le chemin du sous dossier ainsi que le tableau(t) pour continuer a l'instruire et le part of (nom/ext)
        If Err.Number > 0 Then foldercount = foldercount - 1

        Err.Clear
    Next SubFolder
   Debug.Print foldercount
    'End If
End Function

regarde dans le debug

Dudu2 · 7 Février 2021

je perd un peu avec le if else 0.05 pour le disque entier 5560 fichiers

Bof, entre le test du booléen et le test du TypeOf je pense que ça se joue à rien
Avec la variabililité des mesures de temps, je ne crois pas que ce soit mesurable.
De plus je pense qu'un Set Lparent = dparent est plus bien rapide qu'un Set Lparent = FSO.GetFolder(dparent)

ben je veux l'identifier pour faire ma boucle de transpose

Justement c'est à la sortie du 1er appel qu'il faut faire le Transpose car c'est là que la table est remplie.

L'Exit du 1er appel de la fonction ne s'effectue que lorsque tous les appels récursifs sont terminés.
Comme les poupées russes.
A la fin, juste avant End Function soit tu testes ton If Recall = False ou dans mon exemple If Not TypeOf dparent Is Objet et tu fais ton Transpose.

patricktoulon · 7 Février 2021

j'ai trouvé je met ca au propre

patricktoulon · 7 Février 2021

voila voila
le count folder est bon
dans la fonction on ajoute le lparent.subfolders.count et dans la boucle de récursivité j'enleve 1 a chaque tour
donc le count il monte et descend selon nombre de sous dossier de dparent et fini par retomber a zero
quand il est a zero y a plus qu'a

et le tableau ne se promène plus,maintenant le tableau c'est return de la fonction

de 2.25 je passe à 2.30 pour le total disk

purée j’étais jamais aller aussi loin avec FSO

je suis sur que tu va me dir de mettre foldercount en static

VB:

'patricktoulon liste fichier FSO (fonction récursif)
Sub testFSO()
    Dim Racine$, tim, ext$, tbl    'on dimentionne un array de 1 item pour commencer
    Racine = "h:"    ' disque à lister
    tim = Timer
    ext = "*.txt"    ' une partie du nom  et l'extension
    tbl = recherche_récursive(Racine)   ', ext     'appel de la fonction t est injecté comme tel
    MsgBox (Timer - tim) & " secondes ; " & UBound(tbl) & " fichiers avec FSO"
    Cells(1, 1).Resize(UBound(tbl), 1) = tbl
End Sub
'
'
Private Function recherche_récursive(dparent, Optional E As String = "*.*", Optional recall As Boolean = False, Optional foldercount As Long = 0)     ' As Variant
    Static FSO As Object
    Static t()
    Dim Lparent As Object, SubFolder As Object, Ficher

    If Not recall Then ReDim t(0): 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

    foldercount = foldercount + Lparent.subfolders.Count    ' et on rajoute le subfolders.count

    If Dir(Lparent.Path & "\" & E) <> "" Then
        For Each Ficher In Lparent.Files    'on boucle sur les fichiers qui sont dans ce dossier
            If Mid(Ficher, InStrRev(Ficher, "\")) Like E Then ReDim Preserve t(UBound(t) + 1): t(UBound(t) - 1) = Ficher:    ' on redim preserve le tableau(t) avec un item de plus et on instruit l'item avec le chemin de fichier trouvé
        Next
    End If
    If Lparent.subfolders.Count Then
        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é

            On Error Resume Next    '  pour gérer les dossier interdits
            'si il y a des fichiers correspondant a la recherche ou si il y a encore un/des sousdossiers dans ce subfolder on relance
            If Dir(SubFolder.Path & "\" & E) <> "" And Not SubFolder.Path Like "*RECYCLE*" Or SubFolder.subfolders.Count > 0 Then recherche_récursive SubFolder.Path, E, True, foldercount                  ' on rappelle la fonction avec pour argument le chemin du sous dossier ainsi que le tableau(t) pour continuer a l'instruire et le part of (nom/ext)
            foldercount = foldercount - 1    'a chaque appel recursif on enleve 1
            Err.Clear
        Next SubFolder
    End If
    If foldercount = 0 Then
        ReDim tbl(UBound(t), 1 To 1)
        For i = LBound(t) To UBound(t): tbl(i, 1) = t(i): Next
recherche_récursive = tbl
    End If
End Function

ChTi160 · 7 Février 2021

Bonjour le Fil ,le Forum
Il perd 0.05 et il est content lol

de 2.25 je passe à 2.30 pour le total disk

Merci pour ces tests
Jean marie

patricktoulon · 7 Février 2021

re
bonjour ChTi160
ben non je pas suis content et alors?
sachant que la perte est exponentielle sur un disque dur bien rempli les 0.05 se transforme en 10/20/30 secondes en plus voir plus selon le poids du tableau(c'est du string ne l'oublions pas) dans l'avancée de la liste
saucisse !!

ChTi160 · 7 Février 2021

Mdr
Merci pour ce travail !
Jean marie

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

hamzaelhathout

XLDnaute Nouveau

hamzaelhathout

Dudu2

XLDnaute Barbatruc

Pièces jointes

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

ChTi160

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

ChTi160

XLDnaute Barbatruc

Discussions similaires