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

[hamzaelhathout]

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.

 

[Dudu2]

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]

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]

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]

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

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]

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]

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]

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]

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]

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]

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

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]

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]

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

 

[Dudu2]

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

 

[patricktoulon]

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

 

[patricktoulon]

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

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