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

Pour info j'ai essayé aussi des Redim par paquets de 1000 au lieu des Redim de 1 à chaque fois qu'on ajoute un fichier. J'étais presque sûr d'améliorer les performances. Et ben... Non ! Au contraire. Et ça, je ne comprends pas pourquoi mais bon c'est comme ça.

patricktoulon · 5 Février 2021

re
certainement et d'ailleurs c'est normal elle s'alourdi au fur et a mesure la variable
donc si tu lui donne un poid de 1000 items elle tourne avec 1000 items jusqu'au 1001 eme
243 secondes pour le disque C plus de 203000 fichiers contre plus de 4 minutes avant (et c’était déjà rapide)

reste plus qu'a mettre ou ajouter une condition sur les extention ou partie de nom comme mes ancienne version sur dvp

Dudu2 · 5 Février 2021

Y a quand même un truc qui me questionne.
Tu prends le logiciel Everything par exemple.En 2 temps 3 mouvements il t'indexe tous tes drives.
Donc il doit y avoir un moyen d'accéder directement aux blocs de gestion de fichier de NTFS (au moins) sans faire tout ce bazar.

patricktoulon · 5 Février 2021

re
ben je te l'ai déjà donné me semble t'il non?

VB:

Sub CmdDos()
    Dim laChaine As String, x, fichier As String
    Dim tim#
' Exécute la commande dir en ligne de commande .
    tim = Timer
    Shell "C:\Windows\System32\cmd.exe /C dir h:\*.* /s/b >h:\list.txt", vbHide
     x = FreeFile: Open "h:\list.txt" For Binary Access Read As #x: laChaine = String(LOF(x), " "): Get #x, , laChaine:    Close #x
    tbl = Split(laChaine, vbCrLf)
MsgBox Timer - tim & " secondes pour " & UBound(tbl) & " fichiers"
[A1].Resize(UBound(tbl), 1) = Application.Transpose(tbl)
End Sub

là rapide c'est pas le mot je crois

Dudu2 · 5 Février 2021

En méthode Dir() on n'a pas que des erreurs #53 (Fichier introuvable) à cause des accents.
Il y a aussi:
- des erreurs #5 (argument appel de procédure incorrect) à cause d'items protégés (pagefil.sys, hiberfil.sys)
- des erreur #52 (Nom de fichier ou numéro incorrect) sur par exemple un répertoire de nom chez moi ("必应中国精选2" traduit en "??????2").
La question qui se pose alors est: lorsque GetAttr() se plante est-ce sur un fichier ou sur un répertoire ?
On ne peut pas le savoir précisément parce qu'il se plante. Et donc ranger un Item qui se plante dans la liste des fichiers, ce n'est pas forcément correct.

Dudu2 · 5 Février 2021

Ta méthode cmd.exe est parfaite. C'est là-dessus qu'il faut travailler.
Juste (encore) les accents qui sont bouzillés. Et pas seulement ceux des noms de fichiers venus de l'espace.

patricktoulon · 5 Février 2021

normalement pour répondre a question avec dir en ligne de commande tu a acces a certaine propriété
mais je me souviens plus j'ai ca dans mes archives quelque par mais c'est vieux

Dudu2 · 5 Février 2021

Pour la méthode FSO, on a moins de problèmes qu'avec la méthode Dir.
Il y a:
- les erreurs #70 (Autorisation refusée)
- les Error #76 (Chemin non trouvé)
On ne peut pas identifier les fichiers ou répertoires en erreur, donc la seule solution est de les ignorer.

J'ai donc adapté les modules du fichier en post #72.

Dudu2 · 5 Février 2021

Et je te rappelle que le Application.Transpose est un grosse daube et que c'est pour ça que j'ai dû écrire des fonctions de Transpose().

Edit: voir ici aussi -> https://www.excel-downloads.com/threads/vba-application-transpose-resultat-etrange.20052466/

patricktoulon · 5 Février 2021

re
oui perso je n'ai plus de soucis avec transpose depuis le kb je vais beaucoup plus loin que 65535
et si tu tiens a la version DIR en ligne de commande avec correction des accents

VB:

Sub CmdDos()
    Dim laChaine As String, x, fichier As String, tim#
    fichier = Environ("userprofile") & "\DeskTop\list.txt"
    tim = Timer
   ' Exécute la commande DOS Dir .
    Shell "C:\Windows\System32\cmd.exe /C dir h:\*.* /S/b/O/-c >""" & fichier & """, vbHide"
    x = FreeFile: Open fichier For Binary Access Read As #x: laChaine = String(LOF(x), " "): Get #x, , laChaine: Close #x
    tbl = Split(laChaine, vbCrLf)
    arr1 = Array("a~", "a'", "a`", "a^", "a¨", "e`", "e^", "e¨", "i`", "i^", "i¨", "o~", "o`", "o^", "o¨", "u`", "u^", "u¨")   'array caracteres séparés
    arr2 = Array("ã", "à", "à", "â", "ä", "è", "ê", "ë", "ì", "î", "ï", "õ", "ò", "ô", "ö", "ù", "û", "ü")   'array caracteres regroupés
    For i = LBound(tbl) To UBound(tbl)
        For c = LBound(arr1) To UBound(arr1)
            If InStr(1, tbl(i), arr1(c)) > 0 Then tbl(i) = Replace(tbl(i), arr1(c), arr2(c))
        Next c
    Next i
    MsgBox Timer - tim & " secondes pour " & UBound(tbl) & " fichiers"
    [A1].Resize(UBound(tbl), 1) = Application.Transpose(tbl)
Kill fichier
End Sub

on est toujours à 0.01XXXX
ca déchire

je cherche dans mes archives ma version sans les chemins de dossiers je sais que je l'ai ,je l'utilisais dans mes HTA

Dudu2 · 5 Février 2021

Qule KB ? En Windows 7 j'ai toutes les maj même facultatives.
l n'y a pas que le problèmes des accents des noms de fichiers de l'espace comme pour Dir().
Regarde dans le fichier list.txt, tous les accents sont cassés.

patricktoulon · 5 Février 2021

re et alors je les change tous non?
Ah oui je vois purée c'est chiant

Dudu2 · 5 Février 2021

C'est la sortie > sur le fichier Texte qui bouzille tout.

patricktoulon · 5 Février 2021

oui j'ai vu je cherche avec les arguments mais c'est cotton

patricktoulon · 5 Février 2021

re
déjà rien que les fichiers c'est ça
le chemin de sortie et de la racine à examiner sont variabilisés

VB:

Sub CmdDos()
    Dim laChaine As String, x, fichier As String, tim#
    fichier = Environ("userprofile") & "\DeskTop\list.txt"
    racine = "H:\"
    tim = Timer
   ' Exécute la commande DOS Dir .
    Shell "C:\Windows\System32\cmd.exe /C dir " & racine & " /S /b /A:-D >""" & fichier & """, vbHide"
       x = FreeFile: Open fichier For Binary Access Read As #x: laChaine = String(LOF(x), " "): Get #x, , laChaine: Close #x
    tbl = Split(laChaine, vbCrLf)
    arr1 = Array("a~", "a'", "a`", "a^", "a¨", "e`", "e^", "e¨", "i`", "i^", "i¨", "o~", "o`", "o^", "o¨", "u`", "u^", "u¨")  'array caracteres séparés
    arr2 = Array("ã", "à", "à", "â", "ä", "è", "ê", "ë", "ì", "î", "ï", "õ", "ò", "ô", "ö", "ù", "û", "ü")  'array caracteres regroupés
      For i = LBound(tbl) To UBound(tbl)
      x = InStr(1, tbl(i), ",")
      'If x > 0 Then If Mid(tbl(i), x - 1, 1) <> " " Then Mid(tbl(i), x, 1) = "é"'pas bon 
    For C = LBound(arr1) To UBound(arr1)
            If InStr(1, tbl(i), arr1(C)) > 0 Then tbl(i) = Replace(tbl(i), arr1(C), arr2(C))
        Next C
    Next i
    MsgBox Timer - tim & " secondes pour " & UBound(tbl) & " fichiers"
    [A1].Resize(UBound(tbl), 1) = Application.Transpose(tbl)
'Kill fichier
End Sub

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

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Discussions similaires