Lister des fichiers

Bonjour a tous,

J'aimerais via une macro rassembler plusieurs fichiers dans un seul dossier.

J'ai un dossier comprenant 92 sous dossiers qui chacuns a 9 dossiers

J'aimerais réunir tous le contenu des dossiers ayant le même noms, dans un dossier qui sera dans un autre endroit

Un petit schéma sera plus simple

Merci de votre aide

Bonjour Damsa,

Voici un essai que je n'ai malheureusement pas pu tester. Ici, je comprends qu'il y a 92 dossiers comptant chacun 9 sous-dossiers identiques. On parcourt alors tous les fichiers de chaque sous-dossier et on les copie dans le sous-dossier de destination parmi les 9 qui, cette fois-ci, se trouvent tous sous un même dossier parent.

Il faudra mettre le chemin du dossier parent de départ (contenant les 92 dossiers) et le chemin du dossier parent d'arrivée (qui contiendra les 9 dossiers). Si besoin, les dossiers de destination seront créés.

Il y avait probablement plus simple mais j'ai le sentiment qu'en cas d'incompréhension, il sera plus simple de partir de cette base...

Sub CopierFichiers()

Dim strExpath$, strNewpath$, strFolder$, strCurrentFile$, strDestinationFolder$, strNewfile$
Dim arrFolders, arrSubfolders, arrDirectories
Dim i&, k&

strExpath = "C\...\Rename\" '<<< ADAPTER
strNewpath = "C:\...\NewName\" '<<< ADAPTER

arrFolders = ListeDossiers(strExpath)

For i = LBound(arrFolders) To UBound(arrFolders)
    strFolder = arrFolders(i)
    arrSubfolders = ListeDossiers(strFolder)
    arrFolders(i) = arrSubfolders
Next i

arrDirectories = Application.Transpose(Application.Transpose(arrFolders))

For i = LBound(arrDirectories) To UBound(arrDirectories)
    For k = LBound(arrDirectories, 2) To UBound(arrDirectories, 2)
        strCurrentFile = Dir(arrDirectories(i, k) & "*.*")
        While strCurrentFile <> ""
            strDestinationFolder = Replace(arrDirectories(i, k), strExpath, strNewpath)
            If CreerChemin(strDestinationFolder) Then strNewfile = strDestinationFolder & strCurrentFile
            FileCopy strCurrentFile, strNewfile
            strCurrentFile = Dir
        Wend
    Next k
Next i

End Sub

Function ListeDossiers(strRepertoire$)

Dim strDossier$, n&, temp()

strDossier = Dir(strRepertoire, vbDirectory)
While strDossier <> ""
    If Not strDossier Like "*.*" Then
        ReDim Preserve temp(n)
        temp(n) = strRepertoire & strDossier & "\"
        n = n + 1
    End If
    strDossier = Dir
Wend
ListeDossiers = temp

End Function

Function CreerChemin(strChemin$) As Boolean

Dim temp, strRepertoire$, i&

If Right(strChemin, 1) = "\" Then strChemin = Left(strChemin, Len(strChemin) - 1)
temp = Split(strChemin, "\")
strRepertoire = temp(0)
If UBound(temp) > 0 Then
    For i = 1 To UBound(temp)
        strRepertoire = strRepertoire & "\" & temp(i)
        If Dir(strRepertoire, vbDirectory) = "" Then MkDir strRepertoire
    Next i
    CreerChemin = true
End If

End Function

Cdlt,

Merci de la réponse, j'ai testé, mais j'ai une erreur à l'exécution.

Apparemment c'est au niveau de la ligne

arrDirectories = Application.Transpose(Application.Transpose(arrFolders))

je ne vois pas bien, l'erreur

Dans votre dossier "Rename", vous avez bien 92 dossiers qui contiennent tous 9 dossiers ?

Edit : J'ai fait quelques essais. J'ai rencontré des bugs après mais la ligne en question n'est pas bloquante chez moi. Voici un nouveau code en attendant :

Sub test()

Dim strExpath$, strNewpath$, strFolder$, strCurrentFile$, strDestinationFolder$, strReplace$, strConserve$
Dim arrFolders, arrSubfolders, arrOrigine, arrDestination()
Dim i&, k&

strExpath = ThisWorkbook.Path & "\Rename\"
strNewpath = ThisWorkbook.Path & "\Newname\"

'TABLEAU CONTENANT LES SOUS-DOSSIERS DE RENAME
arrFolders = ListeDossiers(strExpath)

'REMPLACEMENT REPERTOIRE DE CHAQUE SOUS-DOSSIER PAR ARRAY CONTENANT REPERTOIRES DE SES PROPRES SOUS-DOSSIERS
For i = LBound(arrFolders) To UBound(arrFolders)
    strFolder = arrFolders(i)
    arrSubfolders = ListeDossiers(strFolder)
    arrFolders(i) = arrSubfolders
Next i

'TABLEAU DES REP DE SOUS-DOSSIERS REMIS SOUS FORME d'ARRAY 2D (TRANSPO DE L'ARRAY D'ARRAYS)
arrOrigine = Application.Transpose(Application.Transpose(arrFolders))
ReDim arrDestination(1 To UBound(arrOrigine), 1 To UBound(arrOrigine, 2))

'ETABLISSEMENT DU TABLEAU DES REP DE DESTINATION PAR CORRESPONDANCE (ET LE CAS ECHANT CREATION DES REPS)
For i = LBound(arrOrigine) To UBound(arrOrigine)
    For k = LBound(arrOrigine, 2) To UBound(arrOrigine, 2)
        strReplace = Left(arrOrigine(i, k), Len(arrOrigine(i, k)) - 1)
        strConserve = Split(strReplace, "\")(UBound(Split(strReplace, "\"))) & "\"
        strDestinationFolder = Replace(arrOrigine(i, k), arrOrigine(i, k), strNewpath & strConserve)
        If CreerChemin(strDestinationFolder) = strDestinationFolder Then arrDestination(i, k) = strDestinationFolder
    Next k
Next i

'PARCOURT CHAQUE FICHIER DE CHAQUE REP ORIGINE ET COPIE DANS REP DESTINATION
For i = LBound(arrOrigine) To UBound(arrOrigine)
    For k = LBound(arrOrigine, 2) To UBound(arrOrigine, 2)
        strCurrentFile = Dir(arrOrigine(i, k) & "*.*")
        While strCurrentFile <> ""
            FileCopy arrOrigine(i, k) & strCurrentFile, arrDestination(i, k) & strCurrentFile
            strCurrentFile = Dir
        Wend
    Next k
Next i

End Sub

Function ListeDossiers(strRepertoire$)

Dim strDossier$, n&, temp()

strDossier = Dir(strRepertoire, vbDirectory)
While strDossier <> ""
    If Not strDossier Like "*.*" Then
        ReDim Preserve temp(n)
        temp(n) = strRepertoire & strDossier & "\"
        n = n + 1
    End If
    strDossier = Dir
Wend
ListeDossiers = temp

End Function

Function CreerChemin(strChemin$) As String

Dim temp, strRepertoire$, i&

If Right(strChemin, 1) = "\" Then strRepertoire = Left(strChemin, Len(strChemin) - 1) Else strRepertoire = strChemin
temp = Split(strRepertoire, "\")
strRepertoire = temp(0)

If UBound(temp) > 1 Then
    For i = 1 To UBound(temp)
        strRepertoire = strRepertoire & "\" & temp(i)
        If Dir(strRepertoire, vbDirectory) = "" Then MkDir strRepertoire
    Next i
    CreerChemin = strRepertoire & "\"
End If

End Function