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
Mais le même nom copié, et cette fois collé dans l'éditeur VBA:
1612638155615.png
 

Dudu2

XLDnaute Barbatruc
Et si tu fais ça:
VB:
Sub a()
    MsgBox Len(Dir("H:\Téléchargements\720p - Les 7 ACCORDS jazz manouche a` connai^tre (majeur, mineur, 7ème...).webm"))
    MsgBox Len(Dir("H:\Téléchargements\720p - Les 7 ACCORDS jazz manouche à connaître (majeur, mineur, 7ème...).webm"))
End Sub
Tu auras 0 dans les 2 cas !

Je vais faire un dump hexa des différents cas.
 

Dudu2

XLDnaute Barbatruc
Il faut se taper la lecture de ça: https://docs.microsoft.com/en-us/windows/win32/intl/unicode-and-character-sets
Mais globalement, y a des applications qui le gèrent et d'autres non.
Et le Dir() VBA ou DOS soit ne le gère pas de toute évidence. Ni MsgBox. Et donc y a pas grand chose à faire.

Ça veut dire aussi que la bidouille de remplacement des caractères n'a pas vraiment de sens.
Il faudrait récupérer le nom directement en Unicode.
Mais mon NomItem = StrConv(NomItem, vbUnicode ou vbFromUnicode) au doigt mouillé n'est pas très convainquant :(.
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
Bonjour @Dudu2
ok effectivement c'est négatif
ce matin je me suis dit comment accélérer FSO dans une recherche de fichiers avec extension précise ou une partie du nom
le problème c'est Fso parcours tout le dossier
il faut donc tester un like (ou autre methode sur les fichiers )
si il y a 1 fichier recherché et 1000 autre qui ne correspondent pas à la recherche ben fso s'en fout lui il scrute les 1001 fichiers
et c'est pour ça qu'il est plus long
donc comment tester le dossier si il contient au moins un fichier correspondant au critère
ben a vrai dir c'est simple
puisque qu'un dir simple(dir(chemindossier &"\*.txt")) nous donne le premier
avant de boucler sur les fichiers on fait le test dir
exemple sur mon disque H: 4590 fichiers; je cherche les "*read*.text"

j'en ai 2 de fichier comme ça dans deux (sub)dossiers quelque part dans le disque dur

sans ce test il va mettre autant de temps que le listage du disque entier puisque fso fait le tour complet

sans ce test entre 1.2XXXX et 1.5XXXXx secondes(4590 fichiers visités dans 226 dossiers)
avec ce test je tombe entre 0.16XXXXXX et 0.22

voila donc ma fonction FSO revue et corrigée

alors bien sur le test avec une partie du nom pourrait éventuellement louper les fichier (du au problème de dir )mais pour l’extension c'est tout benef'
test sans; et re teste en débloquant la condition Dir
VB:
'patricktoulon liste fichier FSO (fonction récursif)
Sub testFSO()
    Dim Racine$, tim, ext$
    ReDim t(0)     'on dimentionne un array de 1 item pour commencer
    Racine = "H:"    ' disque à lister
    tim = Timer
    ext = "*read*.txt"    ' une partie du nom  et l'extension
    recherche_récursive Racine, t, ext    'appel de la fonction t est injecté comme tel
    MsgBox (Timer - tim) & " secondes ; " & UBound(t) & " fichiers avec FSO"
    Cells(1, 1).Resize(UBound(t), 1) = Application.Transpose(t)
End Sub
'
'
Private Function recherche_récursive(dparent, t, Optional E As String = "*.*")    ' As Variant
    Dim FSO As Object, Lparent As Object, SubFolder As Object, Ficher

    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é (condition déplacée) autant ne pas tomber dessus et donc les occulté carrément de la recherche
    'If Not Lparent Like "*RECYCLE.*" And Not Lparent Like "BIN\" And Not Lparent Like "*System Volume Information*" Then
    '----------------------------------------------------------------
    'If Dir(Lparent.Path & "\" & E) <> "" Then    ' si le dossier contient des fichiers avec une  partie du nom correspondant à  (E) alors on le scrute
    For Each Ficher In Lparent.Files    'on boucle sur les fichiers qui sont dans ce dossier
        If 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é
            If Not SubFolder.Path Like "*RECYCLE.*" And Not SubFolder.Path Like "BIN\" And Not SubFolder.Path Like "*System Volume Information*" Then
                If Dir(SubFolder.Path & "\" & E) <> "" Or SubFolder.subfolders.Count > 0 Then
                    recherche_récursive SubFolder.Path, t, E   ' on rappelle la fonction avec pour argument le chemin du sous dossier ainsi que le tableau(t) pour continuer a l'instruire
                End If
            End If
        Next SubFolder
    End If
    'End If
End Function

:)
 

Dudu2

XLDnaute Barbatruc
Y a un truc qui me dépasse complètement. Mais ça ce sont les arcanes complexes des jeux de caractères.

Dump Hexa en TextBox du nom de fichier retourné par VBA DIR:
1612696861127.png


Dump Hexa en TextBox du nom de fichier retourné par VBA FSO:
1612696934634.png


Ce sont les mêmes codes Hexa mais les caractères du FSO sont bien interprétés en Unicode et pas ceux du DIR. Je ne sais pas pourquoi, ça me dépasse complètement :). Comme si le String était qualifié par son code page.
Je vais arrêter de chercher sous peine d'y passer encore des jours.
 

Pièces jointes

  • VBA Fonction dump Hexa.txt
    1 007 bytes · Affichages: 5
Dernière édition:

patricktoulon

XLDnaute Barbatruc
Bonjour @Dudu2
et oui c'est ça qui me perturbe justement
il se passe quelque chose lors du open for input
j'ai bien essayé avec adob.stream ou l'on peut modifier le charset mais c'est pareil

ensuite FSO ok oui mais sur C c'est une vrai galère nos conditions de dossier interdits ne sont pas suffisantes
et quand enfin on arrive a gérer(sauter) les erreurs la recherche s’arrête a document tout les autres dossiers sont occultés visiblement
autrement dit FSO plante a tout bout de champs sur C

une qui fonctionne hyper rapide sans en manquer un seul avec fso mais sur un autre disque que C
VB:
'patricktoulon liste fichier FSO (fonction récursif)
Sub testFSO()
    Dim Racine$, tim, ext$
    ReDim t(1)     'on dimentionne un array de 1 item pour commencer
    Racine = "h:"    ' disque à lister
    tim = Timer
    ext = "*.txt" ' une partie du nom  et l'extension
    recherche_récursive Racine, t, ext   'appel de la fonction t est injecté comme tel
    MsgBox (Timer - tim) & " secondes ; " & UBound(t) & " fichiers avec FSO"
    Cells(1, 1).Resize(UBound(t), 1) = Application.Transpose(t)
End Sub
'
'
Private Function recherche_récursive(dparent, t, Optional E 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
        '----------------------------------------------------------------
         If Dir(Lparent.Path & "\" & E) <> "" Then ' si le dossier contient des fichiers avec la pertie (E) alors on le scrute
            For Each Ficher In Lparent.Files    'on boucle sur les fichiers qui sont dans ce dossier
                If Ficher Like E Then t(UBound(t) - 1) = Ficher: ReDim Preserve t(UBound(t) + 1): ' 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
                If Dir(SubFolder.Path & "\" & E) <> "" Or SubFolder.subfolders.Count>0 Then recherche_récursive SubFolder.Path, t, E                  ' on rappelle la fonction avec pour argument le chemin du sous dossier ainsi que le tableau(t) pour continuer a l'instruire
            Err.Clear
            Next SubFolder
        End If
    End If
   End Function
  • disque H: -->5560 fichiers
  • 226 dossiers dont 8 enfants directs du disque
  • 22 fichiers texte disséminés un peut par tout dans les sous dossiers
  • trouvé en 0.17XX secondes
 

patricktoulon

XLDnaute Barbatruc
re
j'ai ajouté la recherche uniquement sur le nom et plus sur le chemiin complet
VB:
'patricktoulon liste fichier FSO (fonction récursif)
Sub testFSO()
    Dim Racine$, tim, ext$
    ReDim t(1)     'on dimentionne un array de 1 item pour commencer
    Racine = "h:"    ' disque à lister
    tim = Timer
    ext = "*.txt" ' une partie du nom  et l'extension
    recherche_récursive Racine, t, ext   'appel de la fonction t est injecté comme tel
    MsgBox (Timer - tim) & " secondes ; " & UBound(t) & " fichiers avec FSO"
    Cells(1, 1).Resize(UBound(t), 1) = Application.Transpose(t)
End Sub
'
'
Private Function recherche_récursive(dparent, t, Optional E As String = "*.*", Optional recall As Boolean = False) ' As Variant
    Static FSO As Object
    Dim Lparent As Object, SubFolder As Object, Ficher, a

    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
    '-------------------------------------------------------------
    '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
        '----------------------------------------------------------------
         If Dir(Lparent.Path & "\" & E) <> "" Then ' si le dossier contient des fichiers avec la partie (E) alors on le scrute
            For Each Ficher In Lparent.Files    'on boucle sur les fichiers qui sont dans ce dossier
                  If Mid(Ficher, InStrRev(Ficher, "\")) Like E Then t(UBound(t) - 1) = Ficher: ReDim Preserve t(UBound(t) + 1):  ' 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
                If Dir(SubFolder.Path & "\" & E) <> "" Or SubFolder.subfolders.Count > 0 Then recherche_récursive SubFolder.Path, t, E, True               ' on rappelle la fonction avec pour argument le chemin du sous dossier ainsi que le tableau(t) pour continuer a l'instruire
            Err.Clear
            Next SubFolder
        End If
    End If
    'recherche_récursive = t   'a la fin la fonction devient le tableau (t)
End Function
 

patricktoulon

XLDnaute Barbatruc
re
tu me diras la quelle est la plus rapide
version 1
VB:
'patricktoulon liste fichier FSO (fonction récursif)
Sub testFSO()
    Dim Racine$, tim, ext$
    ReDim t(0)     'on dimentionne un array de 1 item pour commencer
    Racine = "h:"    ' disque à lister
    tim = Timer
    ext = "*.txt"    ' une partie du nom  et l'extension
    recherche_récursive Racine, t, ext   'appel de la fonction t est injecté comme tel
    MsgBox (Timer - tim) & " secondes ; " & UBound(t) & " fichiers avec FSO"
    If UBound(t) > 0 Then Cells(1, 1).Resize(UBound(t), 1) = Application.Transpose(t)
End Sub
'
'
Private Function recherche_récursive(dparent, t, Optional E As String = "*.*", Optional recall As Boolean = False)    ' As Variant
    Static FSO As Object
    Dim Lparent As Object, SubFolder As Object, Ficher, a

    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
    '-------------------------------------------------------------
    '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*" And Not Lparent Like "*Perflog*" Then
        '----------------------------------------------------------------
        If Dir(Lparent.Path & "\" & E) <> "" Then    ' si le dossier contient des fichiers avec la pertie (E) alors on le scrute
            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
                If Dir(SubFolder.Path & "\" & E) <> "" Or SubFolder.subfolders.Count > 0 Then recherche_récursive SubFolder.Path, t, E, True               ' on rappelle la fonction avec pour argument le chemin du sous dossier ainsi que le tableau(t) pour continuer a l'instruire
                Err.Clear
            Next SubFolder
        End If
    'End If
End Function

version 2

VB:
'patricktoulon liste fichier FSO (fonction récursif)
Sub testFSO()
    Dim Racine$, tim, ext$
    ReDim t(0)     'on dimentionne un array de 1 item pour commencer
    Racine = "h:"    ' disque à lister
    tim = Timer
    ext = "*.txt"    ' une partie du nom  et l'extension
    recherche_récursive Racine, t, ext    'appel de la fonction t est injecté comme tel
    MsgBox (Timer - tim) & " secondes ; " & UBound(t) & " fichiers avec FSO"
    Cells(1, 1).Resize(UBound(t), 1) = Application.Transpose(t)
End Sub
'
'
Private Function recherche_récursive(dparent, t, Optional E As String = "*.*", Optional recall As Boolean = False) ' 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

    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                  ' 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
il faudrait prévoir aussi une autre méthode pour transposer (sait on jamais avec les limites)
 

Discussions similaires

Statistiques des forums

Discussions
315 095
Messages
2 116 170
Membres
112 676
dernier inscrit
little_b