Discussion :

[CaroleNguyenVo]

Bonjour à tous

j'ai créé une macro afin de

1/obtenir une liste de noms de documents dans un dossier

2/ de renommer les images du dossier à partir d'une liste

Le souci, c'est que la formule que j'ai créé m'oblige a avoir le chemin du dossier à chaque fois... et évidemment cela change d'un Utilisateur à l'autre.
J'aimerais donc faire un sorte que par exemple, dans une Feuille1, dans la celulle A1, il suffit de copier coller le chemin du dossier et que je n'ai plus besoin de personnaliser à chaque fois la macro dans ma formule.

Mais je ne sais pas vraiment comment faire, toutes mes tentatives se sont soldées par une échec. Une idée ?

Voici mes 2 codes VBA - en bleu le chemin du dossier que j'aimerai avoir dans une cellule - ma macro s'appelle BEE-RENAMER

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub ChangeNom()
 Dim LastRow2 As Long
    Dim k As Long
    LastRow2 = Range("A" & Rows.Count).End(xlDown).Row
 
    For k = 2 To 5000
 
    Dim AncienNom As String, NouveauNom As String
    AncienNom = "C:\Users\XXXXX\Documents\BEE-RENAMER\" & Range("A" & k)
    NouveauNom = "C:\Users\XXXXX\OneDrive - Robert Bosch GmbH\Documents\BEE-RENAMER\" & Range("B" & k)
    On Error Resume Next
    Name AncienNom As NouveauNom
    If Err = 75 Then Exit Sub
    Next k
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Sub ListeFichiersRepert()
Dim Fso  As Object
Dim MonRepertoire As String, f As Object, x As Integer
Dim f1 As Object, f2 As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
MonRepertoire = "C:\Users\XXXXX\Documents\BEE-RENAMER\"
x = 1
For Each f In Fso.GetFolder(MonRepertoire).Files
    Cells(x, 1).Value = f.Name
    x = x + 1
Next f
x = 1
For Each f1 In Fso.GetFolder(MonRepertoire).SubFolders
    Cells(x, 2).Value = f1.Name
    x = x + 1
    For Each f2 In f1.Files
        Cells(x - 1, 3).Value = f2.Name
        x = x + 1
    Next f2
    x = x - 1
Next f1
End Sub

Merci par avance pour votre aide

[Pierre Fauconnier]

Salut.

Pour un ou deux paramètres, tu peux utiliser une cellule nommée en Excel que tu adresses en VBA. Pour plus de paramètres, je passerais pas un tableau structuré:




Pour nommer la cellule, tu ta sélectionnes puis, dans la zone de noms à gauche de la barre de formule, tu saisis simplement le nom souhaité et tu valides par ENTER (Ne pas oublier!). De cette façon, ce nom vaut pour tout le classeur et tu peux l'utiliser comme une adresse de cellules en VBA.


Tu peux également récupérer le chemin de certains dossiers spéciaux avec ceci (voir la faq pour toutes les valeurs). En passant 5 comme valeur, tu récupères le chemin de "mes documents":

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
Function GetSpecialPath(Value) As String
  Dim oShell As Object
  Dim Item As Object
 
  On Error GoTo Catch:
  Set oShell = CreateObject("Shell.Application")
  GetSpecialPath = oShell.Namespace(Value).self.Path
  Set oShell = Nothing
 
Catch:
  Err.Clear
End Function

[CaroleNguyenVo]

Salut.
Pour nommer la cellule, tu ta sélectionnes puis, dans la zone de noms à gauche de la barre de formule, tu saisis simplement le nom souhaité et tu valides par ENTER (Ne pas oublier!). De cette façon, ce nom vaut pour tout le classeur et tu peux l'utiliser comme une adresse de cellules en VBA.

Ah du coup j'ai essayé mais je pense qu'il manque encore quelque chose, rien ne s'exécute.



J'ai mis l'Excel ici pour voir

Bee-renamer-TEST.xlsm

Une idée de ce que je n'ai pas fait correctement ?

[Pierre Fauconnier]

chez moi, ça fonctionne bien et je récupère bien le chemin...

Cela dit, je travaillerais avec une récursive ET un tableau structuré (voir mon tuto sur les tableaux structurés)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Sub Run()
  Dim fso As Object
 
  Application.ScreenUpdating = False
  If Not Range("t_Fichiers").ListObject.DataBodyRange Is Nothing Then Range("t_Fichiers").ListObject.DataBodyRange.Delete
  Set fso = CreateObject("Scripting.FilesystemObject")
  ListerFichiers fso, Range("chemin")
  Application.ScreenUpdating = True
End Sub
 
Sub ListerFichiers(fso As Object, Chemin As String)
  Dim Folder As Object, File As Object
  Dim i As Long
 
  For Each File In fso.getfolder(Chemin).Files
    i = Range("t_Fichiers").ListObject.ListRows.Add.Index
    Range("t_Fichiers[fichier]")(i).Value = File.Path
  Next
  For Each Folder In fso.getfolder(Chemin).subfolders
    ListerFichiers fso, Folder.Path
  Next
End Sub

Ceci dit, fso pour récupérer juste le nom des fichiers est assez lent, et perso je préfère un dir récursif...

[CaroleNguyenVo]

Bonjour,

Merci pour l'aide

Argh effectivement cela ne marche toujours pas. Voilà ce qui s'affiche quand je demande le débogage



Je pense qu'il reconnait le Chemin mais la macro ne s'exécute pas jusqu'au bout. J'avoue ne pas très bien savoir pourquoi.


Je tenterai le tableau et le dir recursif j'ai juste peur que ça me change tout mon code... et il y a un 2ème module qui a besoin de ça.

[Pierre Fauconnier]

Ton code dit MonRepertoire = "chemin". Le fso cherche donc un répertoire nommé "chemin" ^^
Tu dois écrire MonRepertoire = Range("Chemin").Value.


Au passage, ton code ne contient pas "Option Explicit" en début de module => Tu devrais... (Voir mon billet à ce sujet)

[CaroleNguyenVo]

Bonjour

Super merci ça marche à présent ! Je vais lire de ce pas également tous les liens pour améliorer tout ça et me perfectionner

Je mets la formule complète de la macro pour obtenir la liste au cas où pour ceux que ça intéresse et je ferai la modification sur la macro de renommage des images

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
Sub ListeFichiersRepert()
Dim fso  As Object
Dim MonRepertoire As String, f As Object, x As Integer
Dim f1 As Object, f2 As Object
Set fso = CreateObject("Scripting.FileSystemObject")
MonRepertoire = Range("Chemin").Value(B1)
 
x = 1
For Each f In fso.getfolder(MonRepertoire).Files
    Cells(x, 1).Value = f.Name
    x = x + 1
Next f
x = 1
For Each f1 In fso.getfolder(MonRepertoire).subfolders
    Cells(x, 2).Value = f1.Name
    x = x + 1
    For Each f2 In f1.Files
        Cells(x - 1, 3).Value = f2.Name
        x = x + 1
    Next f2
    x = x - 1
Next f1
End Sub
 
Sub Run()
  Dim fso As Object
 
  Application.ScreenUpdating = False
  If Not Range("t_Fichiers").ListObject.DataBodyRange Is Nothing Then Range("t_Fichiers").ListObject.DataBodyRange.Delete
  Set fso = CreateObject("Scripting.FilesystemObject")
  ListerFichiers fso, Range("chemin")
  Application.ScreenUpdating = True
End Sub
 
Sub ListerFichiers(fso As Object, Chemin As String)
  Dim Folder As Object, File As Object
  Dim i As Long
 
  For Each File In fso.getfolder(Chemin).Files
    i = Range("t_Fichiers").ListObject.ListRows.Add.Index
    Range("t_Fichiers[fichier]")(i).Value = File.Path
  Next
  For Each Folder In fso.getfolder(Chemin).subfolders
    ListerFichiers fso, Folder.Path
  Next
End Sub

Avec le chemin du dossier en celulle B1 donc

et voici ce que j'ai pour le renommage de fichier en masse

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub ChangeNom()
 Dim LastRow2 As Long
    Dim k As Long
    LastRow2 = Range("A" & Rows.Count).End(xlDown).Row
 
    For k = 2 To 5000
 
    Dim AncienNom As String, NouveauNom As String
    AncienNom = Range("Chemin").Value(G1) & Range("A" & k)
    NouveauNom = Range("Chemin").Value(G1) & Range("B" & k)
    On Error Resume Next
    Name AncienNom As NouveauNom
    If Err = 75 Then Exit Sub
    Next k
End Sub

Avec le chemin du dossier en celulle D1 donc

Je nettoierai tout cela dans un 2ème temps

En grand merci pour votre aide