Macro pour renommer les fichiers contenus dans des sous-dossiers

Mettre lefichier sans données confidentielles en pièce jointe sur « mon-partage.fr »
et faire un clic droit-coller le raccourci  dans votre message 

Option Explicit
'---------------------------------------------------------------
Function Nouveau_nom(Fich As String)
Dim Separe, Jour As String, Mois As String, Annee As String
Dim Liste_mois, Num_mois As String

'transformation du nom de ficjier format jjmmmmaaaa en aaaammjj
    'sépare les éléments du nom de fichier
    Separe = Split(Fich)
    Jour = Format(Separe(2), "00")
    Mois = LCase(Separe(3))
    'détermination du numéro de mois avec nom de mois sans accent "é" et majuscule
    If Mois = "février" Or Mois = "décembre" Then: Mois = Replace(Mois, "é", "e")
    Liste_mois = Array("janvier", "fevrier", "mars", "avril", "mai", "juin", "juillet", "aout", "septembre", "octobre", "novembre", "decembre")
    Num_mois = Format(Application.Match(Mois, Liste_mois, 0), "00")
    Annee = Left(Separe(4), 4)

Nouveau_nom Annee & Num_mois & Jour & ".csv"
End Function
'-----------------------------------------------------------------------------------
Sub renommer_fichier()
    Dim objShell As Object, objFolder As Object, oFolderItem As Object
    Dim Chemin As String, Fich As String

    Application.ScreenUpdating = False
    'dossier voulu
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
    On Error Resume Next
    Set oFolderItem = objFolder.Items.Item
    Chemin = oFolderItem.Path
    If Chemin = "" Then Exit Sub

    ChDir Chemin 'dossier des fichiers csv
    Fich = Dir("*.csv")
    While Fich <> ""
        Name Fich As Nouveau_nom(Fich)
     Fich = Dir
    Wend
End Sub