Bonjour à tous,
Voici ce que j’ai fait il y a pas mal de temps,
Sub classement()
Dim emplacement As String
Dim Groupe_fichier As Object
Dim fichier As Object
Dim n As Integer
Dim dossier As Range
Dim a As FileDialog
n = 0
Range("AA:AA").NumberFormat = "@"
Range("AA3").Select
On Error GoTo nada
Set a = Application.FileDialog(msoFileDialogFolderPicker)
a.Show
emplacement = a.SelectedItems(1)
Set Groupe_fichier = CreateObject("scripting.filesystemobject").getfolder(emplacement)
Application.ScreenUpdating = False
For Each fichier In Groupe_fichier.Files
ActiveCell.Offset(n, 0) = Format(FileDateTime(fichier), "dd-mmm-yyyy")
n = n + 1
Next
ActiveCell.CurrentRegion.Name = "liste_repertoire"
For Each dossier In Range("liste_repertoire")
On Error Resume Next
MkDir emplacement & "/" & dossier
For Each fichier In Groupe_fichier.Files
If Format(FileDateTime(fichier), "dd-mmm-yyyy") = dossier Then
Name fichier As emplacement & "/" & dossier & "/" & fichier.Name
End If
Next
Next
ActiveCell.CurrentRegion.Clear
Application.ScreenUpdating = True
MsgBox "Fin du traitement"
Exit Sub
nada:
MsgBox "Vous avez pas choisi un emplacement"
'Will-Fread
End Sub
L’objectif est de créer un dossier pour tous les fichiers dans un dossier en se basant sur la date de sa création.
J’ai personnalisé mon ruban et voila l’résultat.
Cordialement