Comment réorganiser automatiquement des milliers de sous-dossiers et fichie

Bonjour à tous,

Je cherche depuis quelques temps un moyen pour réorganiser des milliers de sous-dossiers et fichiers pour faciliter la recherche de dossiers...

Je m'explique : depuis plusieurs années, je classe mes photos (jpg, psd, etc.) par date de sortie, puis sous-dossiers (lieux). Maintenant, je veux réorganiser l'ensemble vers un nouvel emplacement en les classant par lieux puis par date de sortie (ce sont des versions différentes), comme le schéma ci-dessous :

Auriez-vous une idée pour traiter cela automatiquement ?

Merci d'avance !

Bonjour,

Voici un essai (non fonctionnel sur Mac) avec le fichier exécutant le code se trouvant dans le dossier parent du dossier Photos (et du futur dossier Photos_New) :

Sub Intervertir()

Dim t() As String

Set fso = CreateObject("Scripting.FileSystemObject")
Set fd = fso.GetFolder(ThisWorkbook.Path & "\Photos") 'dossier source

For Each sfd In fd.SubFolders 'pour chaque sous-dossier (dates) du dossier source
    For Each ssfd In sfd.SubFolders 'pour chaque sous-dossier (lieux) des sous-dossiers (dates)
        For Each fil In ssfd.Files 'pour chaque fichier des sous-dossier finaux (lieux)
            n = n + 1 'incrémentation
            ReDim Preserve t(1 To 2, 1 To n) 'redimension tableau accueillant chemin source et chemin destination
            t(1, n) = fil.Path 'chemin source du fichier
            t(2, n) = Join(Array(Replace(fd.Path, fd.Name, fd.Name & "_New"), ssfd.Name, sfd.Name, fil.Name), "\") 'chemin destination
            CreerChemin fso, t(2, n) 'le cas échéant, création des nouveaux répertoires de destination
            fso.copyfile t(1, n), t(2, n) 'copie fichier
        Next fil
    Next ssfd
Next sfd

End Sub

Function CreerChemin(fso As Object, sfilepath$)
t = Split(sfilepath, "\")
spath = t(0)
For i = LBound(t) + 1 To UBound(t) - 1
    spath = spath & "\" & t(i)
    If Not fso.FolderExists(spath) Then fso.CreateFolder (spath)
Next i
End Function

Ici, il faut bien que l'arborescence respecte celle affichée sur l'image : Le dossier Photos contient des sous-dossiers (dates) qui contiennent chacun des sous-dossiers (lieux) qui contiennent chacun des fichiers.

Avant d'exécuter le code, il vaut mieux s'assurer que les noms de fichiers sont uniques...

Cdlt,

Bonjour, je vous remercie !

Je vais étudier votre code pour voir s'il fonctionne sur un pc.

Merci encore !

Oui, sur PC, il fonctionne !

Il faut juste mettre ce code dans un module normal d'un fichier (ex : test.xlsm) qui sera placé dans un dossier (ex : racine) contenant le dossier Photos :

'avant exécution
> Racine
    > Photos
    > test.xlsm

'après exécution
> Racine
    > Photos
    > Photos_New
    > test.xlsm

Cdlt,

Edit:Je n'avais pas vu la solution de 3GB avant de poster.