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]

Il y a 2 problèmes réglés:
- Récupérer les accents normaux (je ne parle pas de corriger les noms de fichiers de l'espace)
- Attendre la fin du DOS pour récupérer le fichier résultat de la redirection du DIR

Sur C:\ ça me donne ça (imbattable)

Le code à condition d'avoir un Application.Transpose correct (perso j'utilise ma fonction pour palier la limite de Application.Transpose)

Option Explicit

Declare Function WaitForSingleObject Lib "Kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Declare Function OpenProcess Lib "Kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Public Const INFINITE = &HFFFF

Sub ListeFichiersRépertoireDOS()
    Const Répertoire = "C:\" ' "H:\Téléchargements\"
    Dim NomRépertoire As String
    Dim TabFichiers() As String
    Dim NbFichiers As Long
    Dim ThisFunctionName As String
    Dim IndexFichier As Integer
    Dim BatchFile As String
    Dim ListFile As String
    Dim Liste As String
    Dim i As Long
    Dim StartTime As Double

    'Commandes DOS à enchaîner
    Const Cmd1 = "chcp 28591 > nul"
    Const Cmd2 = "dir <R> /S /B /A:-D > <F>"

    'Mesure du temps d'exécution
    StartTime = Timer

    'Récupère le nom de cette fonction
    With Application.VBE.ActiveCodePane
        .GetSelection i, 0, 0, 0
        ThisFunctionName = .CodeModule.ProcOfLine(i, 0)
    End With

    'Fichier liste destination du DOS Dir
    ListFile = Environ("TEMP") & "\" & "@@@" & ThisFunctionName & ".txt"
 
    'Complémente éventuellement le nom du répertoire avec '\'
    NomRépertoire = Répertoire
    If Right(NomRépertoire, 1) <> "\" Then NomRépertoire = NomRépertoire & "\"

    'Fichier Batch contenant 2 commandes DOS
    BatchFile = Environ("TEMP") & "\" & "@@@" & ThisFunctionName & ".bat"
    IndexFichier = FreeFile()
    Open BatchFile For Output As #IndexFichier
    Print #IndexFichier, Cmd1
    Print #IndexFichier, Replace(Replace(Cmd2, "<R>", NomRépertoire), "<F>", ListFile)
    Close #IndexFichier

    'Exécute le Batch
    'Shell BatchFile, vbHide
    LaunchAndWait (BatchFile)

    'Charge la table des fichiers
    IndexFichier = FreeFile()

    Open ListFile For Input As IndexFichier
    While Not EOF(IndexFichier)
        Line Input #IndexFichier, Liste
        NbFichiers = NbFichiers + 1
        ReDim Preserve TabFichiers(1 To NbFichiers)
        TabFichiers(NbFichiers) = Liste
    Wend

    MsgBox NbFichiers & " fichiers trouvés" & vbCrLf & _
           "Temps d'exécution " & Timer - StartTime

    'Chargement de la table à partir du fichier
    [A:A].ClearContents
    [A1].Resize(UBound(TabFichiers)) = Application.Transpose(TabFichiers)
End Sub

'---------------------------------------------
'Lance un processus et attend qu'il se termine
'---------------------------------------------
Function LaunchAndWait(ByVal CheminComplet As String) As Long
    Dim ProcessHandle As Long
    Dim ProcessId As Long

    'ProcessId = Shell(CheminComplet, vbNormalFocus)
    ProcessId = Shell(CheminComplet, vbHide)
    ProcessHandle = OpenProcess(&H1F0000, 0, ProcessId)
    LaunchAndWait = WaitForSingleObject(ProcessHandle, INFINITE)
End Function

 

[patricktoulon]

re
manque des déclaration de variable
sinon

par contre avec un peu moins de fichier 4593 on est plus long que dir

 

[patricktoulon]

re
j'avais essayé le chcp 28591 en nul mais ca n'avais pas marcher en lancant la commande sans fichier bath
je regarde

 

[Dudu2]

manque des déclaration de variable

Je viens de corriger.
J'avais aussi essayé sans .bat en liant les 2 commandes avec " & ".
Mais même en direct sous DOS ça ne fonctionnait pas. Il faut les séparer donc j'ai dû faire un .bat.

 

[patricktoulon]

ca sert a quoi to shellandwait ?

 

[Dudu2]

Ça sert à attendre que la commande DOS se termine.
Sinon comme c'est de l'asynchrone, on va commencer à lire le fichier résultat avant que la commande soit finie.
Essaie avec "C:" en remplaçant le ShellAndWait par le Shell en commentaire.

 

[patricktoulon]

ok

 

[Dudu2]

Sinon y a quand même un truc qui me chiffonne.
Avec DOS je trouve dans les 500.000 fichiers dans mon C:.
Avec les autres méthodes dans les 800.000.
Donc y a encore un loup. Peut-être ajouter davantage de sous-options dans le /A du DIR ?

 

[patricktoulon]

ben il y a des fichiers system ou non autorisés qui passe ou pas ,selon la méthode
je me souviens plus je crois que c''est "/i"

 

[Dudu2]

Je verrai ça demain. Quelle affaire cette liste !
T'as été bien inspiré de penser au DIR DOS.

 

[patricktoulon]

d'accords c'est donc un probleme de latence qui rends les nom lisibles ou pas
avec shell les accents sont bizouillés avec shell and wait j'ai les accents

 

[patricktoulon]

quand tu lance sur C plusieurs fois le nombre de fichier est différents

 

[patricktoulon]

tiens @Dudu2 c'est Kado

Option Explicit

Sub CmdDos()
    Dim laChaine$, x&, fichier$, bat$, Commande$, tim#, tbl, tblV, i&, Racine$
    bat = "C:\Users\polux\Desktop\baton.cmd"
    fichier = "C:\Users\polux\Desktop\list.txt"
    Racine = "C:\*.*"
    Commande = "chcp 28591 > nul " & vbCrLf & "dir " & Racine & " /s/b >" & fichier
    'creation du bath
    x = FreeFile: Open bat For Output As #x: Print #x, Commande: Close #x
    tim = Timer
    ShellAndwaitingEndProcess bat 'appel fonction shell améliorée
        'lecture du fichier
    x = FreeFile: Open fichier For Binary Access Read As #x: laChaine = String(LOF(x), " "): Get #x, , laChaine: Close #x
    tbl = Split(laChaine, vbCrLf) 'coupe(array 1 dim)
    'convert aray 1 dim to 2 dim(transpose)
    ReDim tblV(UBound(tbl), 1 To 1)
    For i = 0 To UBound(tbl): tblV(i, 1) = tbl(i): Next
    MsgBox Timer - tim & " seconde(s) pour " & UBound(tblV) & " fichier(s)"
    [A1].Resize(UBound(tblV), 1) = tblV
End Sub
Function ShellAndwaitingEndProcess(ByVal CheminComplet As String) As Long
    Dim ProcessHandle As Long
    Dim ProcessId As Long
    'ProcessId = Shell(CheminComplet, vbNormalFocus)
    ProcessId = Shell(CheminComplet, vbHide)
     'ON PASSE AUX APIS PAYée AU BLACK SANS DECLARATION
    ProcessHandle = ExecuteExcel4Macro("CALL(""Kernel32"",""OpenProcess"",""JJJJ"",""" & 2031616 & """,""" & 0 & """,""" & ProcessId & """)")
    ShellAndwaitingEndProcess = ExecuteExcel4Macro("CALL(""Kernel32"",""WaitForSingleObject"",""JJJJJ"",""" & ProcessHandle & """,""" & INFINITE & """)")
End Function

y va cracker le @Dudu2
ajoute le "/a:-d" si tu veux

 

[Dudu2]

Je ne comprends pas trop tes ExecuteExcel4Macro().
C'est documenté quelque part ?

 

[patricktoulon]

re
bonjour @Dudu2
ben en fait on peut se servir des api en l’exécutant par macro4 c'est une méthode ancienne
ça me permet de ne pas déclarer d'api
et donc d'avoir une fonction passe partout(toute versions excel pour Windows!!!) (32/64 bits)
transportabilité 100%
j'ai donc transformé ma version CMD en fonction

tu colle ça dans n'importe quel excel pour windows et c'est tout bon rien a ajouter

'patricktoulon DIR fichier en ligne de commande( récursif)
Option Explicit
Sub testDIRcmd()
    Dim Racine$, tim#, T
    'Racine = "C:\*.txt"
    Racine = "C:\"
    [A1].CurrentRegion.Clear
    tim = Timer
    T = ListFichierCmdDos(Racine)
    MsgBox Timer - tim & " seconde(s) pour " & UBound(T) & " fichier(s)"
    [A1].Resize(UBound(T), 1).Value = T
End Sub


Function ListFichierCmdDos(Racine$)
    Dim laChaine$, x&, fichier$, bat$, Commande$, tim#, tbl, tblV, i&, arr1, arr2, a&
    arr1 = Array("a`", "a^", "a¨", "e`", "e^", "e¨", "i`", "i^", "i¨", "o`", "o^", "o¨", "u`", "u^", "u¨")      'array caracteres séparés
    arr2 = Array("à", "â", "ä", "è", "ê", "ë", "ì", "î", "ï", "ò", "ô", "ö", "ù", "û", "ü")      'array caracteres regroupés
    bat = "C:\Users\polux\Desktop\baton.cmd"
    fichier = Environ("userprofile") & "\Desktop\list.txt"
    Commande = "chcp 28591 > nul " & vbCrLf & "dir " & Racine & " /s/b /a:-d >" & fichier
    'creation du bath
    x = FreeFile: Open bat For Output As #x: Print #x, Commande: Close #x
    ShellAndwaitingEndProcess bat    'appel fonction shell améliorée
    'lecture du fichier
    x = FreeFile: Open fichier For Binary Access Read As #x: laChaine = String(LOF(x), " "): Get #x, , laChaine: Close #x
    For a = 0 To UBound(arr1)    'on fait le replace dans la chaine globale si defaut present(plus rapide que le replace dans les ligne du tableau)
        If laChaine Like "*" & arr1(a) & "*" Then laChaine = Replace(laChaine, arr1(a), arr2(a))
    Next
    tbl = Split(laChaine, vbCrLf)    'coupe(array 1 dim)
    'convert array 1 dim to 2 dim(transpose)
    ReDim tblV(UBound(tbl), 1 To 1): For i = 0 To UBound(tbl): tblV(i, 1) = tbl(i): Next
    ListFichierCmdDos = tblV
    Kill bat
    Kill fichier
End Function


Function ShellAndwaitingEndProcess(ByVal CheminComplet As String) As Long
    Dim ProcessHandle As Long
    Dim ProcessId As Long
    'ProcessId = Shell(CheminComplet, vbNormalFocus)
    ProcessId = Shell(CheminComplet, vbHide)
    'ON PASSE AUX APIS PAYée AU BLACK SANS DECLARATION
    ProcessHandle = ExecuteExcel4Macro("CALL(""Kernel32"",""OpenProcess"",""JJJJ"",""" & 2031616 & """,""" & 0 & """,""" & ProcessId & """)")
    ShellAndwaitingEndProcess = ExecuteExcel4Macro("CALL(""Kernel32"",""WaitForSingleObject"",""JJJJJ"",""" & ProcessHandle & """,""" & &HF0000 & """)")
End Function

et voilà

tu remarquera que les replace se font sur la chaine complète (plus rapide que replacer dans les items qui me forcerait a ajouter une Neme boucle sur les items

tu remarquera aussi que je transpose pas je redim un tableau 2 dim
en effet avec ta version me mettait des N/A a partir de 6000 environ

et pour répondre a ta question non c'est plus tellement documenté mais tu trouve des exemples sur la toile

je peux cependant te donner quelque exemple que je me suis fait avec certaines api que l'on utilise souvent

en gros moins de 14 secondes pour C avec 240000 fichiers