Renommer des dossiers en VBA

[Jacques25]

Bonjour à tous,

En vue de l'amélioration d'une gestion de dossiers j'aurai voulu savoir s'il était possible de renommer des dossiers en masse. Je m'explique :

J'ai un dossier comportant environ 650 dossiers (fournisseurs) composés eux mêmes d'une arborescence quasi identique.
J'ai une base de donnée Excel qui reprend en toute logique au minimum ces 650 noms de fournisseurs + quelques autres.
Avec le temps et les vieilles habitudes certains noms de fournisseurs ont dérivés, les dossiers n'ont plus exactement les mêmes noms que dans la base de données (BDD).

Mon idée ou plutôt mes idées seraient :

1 (en priorité) : de récupérer le nom de tous mes dossiers, effectuer une comparaison avec la liste dans la base de données et pouvoir renommer les dossiers n'ayant par leur identiques dans la BDD soit par une boite de dialogue ou autre

2 : faire juste le comparatif entre les noms de dossiers et les noms dans la BDD auquel cas il me resterait juste à traiter au cas par cas

Le but étant d'éviter de faire tout ça à la main.

Dîtes moi ce dont vous auriez besoin si vous souhaitez/pouvez m'aider.

merci à tous.
Jack.

 

[MJ13]

Re : Renommer des dossiers en VBA

Bonjour Jack


Ce matin, j'ai eu le même problème, je voulais renommer des dossiers et sous dossiers qui étaient trop long (Sup à 190 caractères) et je n'ai pas réussi à trouver un code pour renommer un dossier sans déplacer les fichiers vers le nouveau dossier avec le nom raccourci.

Donc, ça m'intéresse si quelqu'un a un code VBA pour renommer un dossier contenant des fichiers facilement (genre Name oldDossier as New Dossier).

 

[david84]

Re : Renommer des dossiers en VBA

Bonjour, salut Michel,
à tester :

'cocher la référence Microsoft Scripting Runtime
Sub Renommer_dossier()
Dim oFSO As Scripting.FileSystemObject
Dim oFld As Scripting.Folder
'Instanciation du FSO
Set oFSO = New Scripting.FileSystemObject
'Instanciation du dossier
Set oFld = oFSO.GetFolder("C:\Nom_du_dossier") 'chemin complet du dossier
Debug.Print oFld.Name 'nom actuel du dossier
oFld.Name = "nouveau_nom" 'nouveau nom
Debug.Print oFld.Name 'nouveau nom du dossier
End Sub

A+

 

[MJ13]

Re : Renommer des dossiers en VBA

Bonjour David

Merci pour ce code qui fonctionne pour un nom de dossier .

Mais j'ai des dossier avec jusque 16 sous-dossiers, donc, là cela va être galère à gérer.

Sinon, j'ai fait une petite appli pour que ce soit plus facile . Par contre elle n'est pas diffusable en l'état, il faut que je la structure.

 

[david84]

Re : Renommer des dossiers en VBA

Cet exemple était simplement destiné à montrer que la propriété Name de l'objet Folder est en lecture-écriture.
Une fois que l'on sait cela il n'y a aucune difficulté sur le principe à l'appliquer à une recherche de dossier et sous-dossiers en utilisant les objets Folder et SubFolder de l'objet FileScriptingObject.
A+

 

[MJ13]

Re : Renommer des dossiers en VBA

Re

Oui, c'est vrai, il faudra que je m'y penche .

Mais quand même, ils auraient pu faire plus simple .

 

[BOISGONTIER]

Re : Renommer des dossiers en VBA

Bonsoir,

Sub essai()
  Name "c:\xx" As "c:\xxy"   ' renomme le répertoire c:\xx en c:\xxy
End Sub

Exemple pour renommer des fichiers avec: Name ancien_nom As NouveauNom

http://boisgontierjacques.free.fr/fichiers/Fichier/jb-ListeFichiersRepertoireRenomme.xls

On peut faire la même chose pour des dossiers. Il faut définir la relation entre l'ancien nom et le nouveau nom.

Gestion des fichiers et répertoires

JB

 

[BOISGONTIER]

Re : Renommer des dossiers en VBA

Bonjour,

Remplace les espaces par le caractère _ dans les noms de répertoire

Dim ligne, nivMax, debOrg
Sub arborescenceRepertoire()
  racine = ChoixDossier()     ' ou un répertoire C:\xxx e.g.
  If racine = "" Then Exit Sub
  Range("A2:A30000").ClearContents
  lignedeb = 2
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dossier_racine = fs.GetFolder(racine)
  ligne = lignedeb
  nivMax = 4
  Lit_dossier dossier_racine, 1, nivMax, ""
End Sub

Sub Lit_dossier(ByRef dossier, ByVal niveau, ByVal nivMax, parent)
   Cells(ligne, 1) = dossier.Path
   ligne = ligne + 1
   For Each d In dossier.SubFolders
     If niveau <= nivMax Then Lit_dossier d, niveau + 1, nivMax, dossier.Path
   Next
End Sub

Function ChoixDossier()
    If Val(Application.Version) >= 10 Then
       With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ActiveWorkbook.Path & "\"
        .Show
        If .SelectedItems.Count > 0 Then
           ChoixDossier = .SelectedItems(1)
        Else
           ChoixDossier = ""
        End If
       End With
     Else
       ChoixDossier = InputBox("Répertoire?")
     End If
End Function

Sub modifie()
  Set Rng = Range("A2:A" & [A65000].End(xlUp).Row)
  For Each c In Rng
    chemin1 = c.Value
    chemin2 = Replace(c.Value, " ", "_")
    Name chemin1 As chemin2
    Rng.Replace chemin1, chemin2
  Next c
End Sub

Remplace des anciens noms de répertoire par les nouveaux

Dim ligne, nivMax
Sub arborescenceRepertoire()
  racine = ChoixDossier()     ' ou un répertoire C:\xxx e.g.
  If racine = "" Then Exit Sub
  Range("A2:A30000").ClearContents
  lignedeb = 2
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dossier_racine = fs.GetFolder(racine)
  ligne = lignedeb
  nivMax = 4
  Lit_dossier dossier_racine, 1, nivMax, ""
End Sub

Sub Lit_dossier(ByRef dossier, ByVal niveau, ByVal nivMax, parent)
   Cells(ligne, 1) = dossier.Path
   Cells(ligne, 2) = dossier.Path
   ligne = ligne + 1
   For Each d In dossier.SubFolders
     If niveau <= nivMax Then Lit_dossier d, niveau + 1, nivMax, dossier.Path
   Next
End Sub

Function ChoixDossier()
    If Val(Application.Version) >= 10 Then
       With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ActiveWorkbook.Path & "\"
        .Show
        If .SelectedItems.Count > 0 Then
           ChoixDossier = .SelectedItems(1)
        Else
           ChoixDossier = ""
        End If
       End With
     Else
       ChoixDossier = InputBox("Répertoire?")
     End If
End Function

Sub modifie()
  Set Rng = Range("A2:A" & [A65000].End(xlUp).Row)
  For Each c In Rng
    chemin1 = c.Value
    chemin2 = c.Offset(, 1).Value
    Name chemin1 As chemin2
    Rng.Replace chemin1, chemin2
    Set Rng2 = Range("A" & c.Row + 1 & ":A" & [A65000].End(xlUp).Row)
    Rng2.Offset(, 1).Replace chemin1, chemin2
  Next c
End Sub

http://boisgontierjacques.free.fr/fichiers/Fichier/ArborescenceRepertoireFichiersModifie.xls

JB

 

[Jacques25]

Re : Renommer des dossiers en VBA

Bonjour à tous,

Merci pour vos différentes propositions, je vais adapter ça à mon fichier (en tout cas essayer) et je vous retiens au courant.
Je reviendrai certainement vers vous pour quelques adaptations.

Encore merci
Bonne journée à tous.

Jack

 

[MJ13]

Re : Renommer des dossiers en VBA

Bonjour à tous


Merci JB pour ces codes qui ont l'air de fonctionner, alors que je n'avais pas réussi avec name, mais je me demande si ce n'était dû au fait que j'avais un apostrophe (quote) dans le nom d'un des sous-dossiers .

Donc éviter de mettre des apostrophe dans les noms de dossiers et de fichiers et pas de points aussi, sauf, bien sûr avant l'extension de fichier .