Microsoft 365 [Résolu] renommer des dossiers en masse par rapport à une liste

Sub Renommer_dossiers()
Dim chemin$, ancien, nouveau, i%
chemin = ThisWorkbook.Path & "\"
ancien = Array("Arbre", "Buche", "Cadenas")
nouveau = Array("00001 - Arbre", "00003 - Buche", "00002 - Cadenas")
For i = 0 To UBound(ancien)
    If Dir(chemin & ancien(i), vbDirectory) <> "" Then Name chemin & ancien(i) As chemin & nouveau(i)
Next
End Sub

Sub Renommer_dossiers()
Dim chemin$, i&, n&
chemin = ThisWorkbook.Path & "\"
With [A1].CurrentRegion
    For i = 2 To .Rows.Count
        If Dir(chemin & .Cells(i, 1), vbDirectory) <> "" Then
            n = n + 1
            Name chemin & .Cells(i, 1) As chemin & .Cells(i, 2)
        End If
    Next
End With
MsgBox n & " dossier(s) renommé(s)"
End Sub

Sub Liste_dossiers()
Dim fso As Object, chemin$, dossier As Object, n&
Set fso = CreateObject("Scripting.FileSystemObject")
chemin = ThisWorkbook.Path
Application.ScreenUpdating = False
Range("A2:A" & Rows.Count).ClearContents 'RAZ
For Each dossier In fso.GetFolder(chemin).SubFolders
    n = n + 1
    Cells(n + 1, 1) = dossier.Name
Next
End Sub