Changer nom de fichier pdf suivant tableau excel.

**Anthonydu62** · 17/06/2025, 10h36

Bonjour à toutes et tous.
Voila, depuis un certain temps (un temps certain...) je dois tous les mois faire une extraction d'un pro-logiciel et renommer les fichiers pour les envoyer à la direction.
Cela me prend beaucoup de mon temps (dans mon exemple j'ai mis 5 lignes d'information, en réalité, j'en ai plus de 350 lignes).
J'aurais voulu savoir:
A partir du tableau excel
Nom : Capture d’écran 2025-06-17 080337.jpg
Affichages : 86
Taille : 36,7 Ko

Nom : Capture d’écran 2025-06-17 080337.jpg
Affichages : 86
Taille : 36,7 Ko

En VBA, rechercher les 7 premiers caractères présent sur la colonne A (Origine) correspondant au 7 premiers caractères des fichiers ce trouvant dans un dossier, et si il y a correspondance, le renommer du nom contenu dans la colonne B, C,D ou E...
Pour information, je suis une quiche en VBA.
Merci de votre aide.
Anthony

**rMist2024** · 17/06/2025, 14h12

Essaie ce code, entrer le nom de ta feuille actuellement il est configuré à Feuil1
Entrer aussi le chemin de rechercher pour les fichiers

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
Sub ChangerNoms()
Dim i As Long, nPos As Long
Dim Dic As New Collection
Dim nName As String, nNew As String, Ext As String
Dim oDossier, oFile, fso As Object
oDossier = "C:\Users\pc\Desktop\fld"
With Worksheets("Feuil1")
  For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
      nName = Left(.Cells(i, "A"), 7)
      Dic.Add i, UCase(nName)
  Next
  Set fso = CreateObject("Scripting.Filesystemobject")
  For Each oFile In fso.GetFolder(oDossier).Files
     nName = fso.GetBaseName(oFile.Name)
     nName = Left$(nName, 7)
     On Error Resume Next
     nPos = Dic(UCase(nName))
     If Err.Number = 0 Then
       Ext = fso.GetExtensionName(oFile.Name)
       If Ext <> "" Then: Ext = "." & Ext
       nNew = oFile.ParentFolder & "\" & .Cells(nPos, "B") & Ext
       oFile.Move nNew
     Else
       Err.Clear
     End If
     On Error GoTo 0
  Next
End With
 
End Sub

**Anthonydu62** · 17/06/2025, 15h18

Je viens de tester, il affiche une erreur:

Erreur d'exécution 457:
Cette clé est déjà associé à un élément de cette collection.

Pour moi c'est du charabia.

En tout cas merci pour ton aide.

**Anthonydu62** · 17/06/2025, 15h36

J'ai supprimé la première ligne de le feuille excel et là une autre erreur:

Erreur d'exécution 5:
Argument ou appel de procédure incorrect.

**tototiti2008** · 17/06/2025, 16h02

Bonjour,

Moi je n'ai pas tout compris
Les fichiers doivent être renommés dans les noms de toutes les colonnes remplies ou la dernière remplie ?
pourquoi les colonnes vides on des - dedans, le - est-il tapé ?

**Anthonydu62** · 17/06/2025, 16h05

pour démarrer, si on y arrive avec les colonne A et B, je serais heureux.

Oui les - sont tapés, c'est en format texte.

**tototiti2008** · 17/06/2025, 16h07

Re,

Sinon, à la question

Les fichiers doivent être renommés dans les noms de toutes les colonnes remplies ou la dernière remplie ?

quelle est la réponse ?

**tototiti2008** · 17/06/2025, 16h25

re,

Devrait renommer les fichiers colonne A en colonne B (dossier à adapter)

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
Sub RenommFic()
Dim Doss As String, Liste, i As Long, Fic As String, Ext As String
    Doss = "C:\Users\toto\Desktop\aa\" 'dossier des fichiers à renommer
    Liste = Range("A1").CurrentRegion.Value
    For i = 2 To UBound(Liste, 1)
        Fic = Dir(Doss & Left(Liste(i, 1), 7) & "*")
        If Fic <> "" Then
            Ext = Mid(Fic, InStrRev(Fic, ".") + 1, 10000)
            Name Doss & Fic As Doss & Liste(i, 2) & "." & Ext
        End If
    Next i
End Sub

**Anthonydu62** · 17/06/2025, 16h25

La colonne A c'est le nom des fichiers d'origine créés par un logiciel.
Les colonnes B, C, D... sont les mois des extractions.
Pour faire plus simple, au mois de mai, c'est tel nom, au mois de juin....

On peu faire plus simple si vous voulez en prenant en compte qu'1 seul mois. Après je n'aurais qu'a faire un copier collé.

**rMist2024** · 17/06/2025, 17h24

Cette clé est déjà associé à un élément de cette collection.

Cela veut dire qu'il y a un doublon dans la colonne A, deux éléments ont les mêmes sept premières lettres.

**Anthonydu62** · 17/06/2025, 17h40

Effectivement, il y avait un doublon du a une erreur de saisie de ma part pour les tests.

Le problème maintenant, c'est qu'il fait le travail mais uniquement pour la dernière ligne.
J'ai mis des MsgBox pour voir, il lis pourtant bien toutes les lignes du tableau.
Mais ne fait le changement que pour la dernière.

**rMist2024** · 17/06/2025, 18h30

Je viens de corriger l'erreur un oubli ou mauvaise manip :On Resume Next doit être placé avant la ligne de test de existence dans la collection

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
Sub ChangerNoms()
Dim i As Long, nPos As Long
Dim Dic As New Collection
Dim nName As String, nNew As String, Ext As String
Dim oDossier, oFile, fso As Object
oDossier = "C:\Users\pc\Desktop\fld"
With Worksheets("Feuil1")
  For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
      nName = Left(.Cells(i, "A"), 7)
      Dic.Add i, UCase(nName)
  Next
  Set fso = CreateObject("Scripting.Filesystemobject")
  For Each oFile In fso.GetFolder(oDossier).Files
     nName = fso.GetBaseName(oFile.Name)
     On Error Resume Next
     nPos = Dic(UCase(nName))
     If Err.Number = 0 Then
       Ext = fso.GetExtensionName(oFile.Name)
       If Ext <> "" Then: Ext = "." & Ext
       nNew = oFile.ParentFolder & "\" & .Cells(nPos, "B") & Ext
       oFile.Move nNew
     Else
       Err.Clear
     End If
     On Error GoTo 0
  Next
End With
 
End Sub

Remarque importante :le code actuel compare le nom complet du fichier avec les sept premières lettres des éléments de la colonne A, si la longueur du nom du fichier est variable et dépasse les sept lettres alors ajouter cette ligne pour ne comparer que les sept lettres:

Code :

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

1
2
3
    nName = fso.GetBaseName(oFile.Name)
     nName = Left$(nName, 7) 'Ajouter cette ligne 
     On Error Resume Next

**Anthonydu62** · 18/06/2025, 08h14

Superbe, franchement tu me soulage d'un sacré poids de travail, chaque mois, je passais une journée minimum pour faire un travail pas du tout passionnant.
Un GRAND Merci.

**Anthonydu62** · 18/06/2025, 08h31

Un dernier petit truc,
Comment je peux faire pour qu'il me demande dans quelle colonne de doit prendre les nouveaux noms.
Ici avec ton programme il prend la colonne B, si je veux prendre la colonne C, ce serait cool qu'il y est un message me demandent quelle colonne je dois prendre.
Merci

**Philippe Tulliez** · 18/06/2025, 10h08

Bonjour,

ce serait cool qu'il y est un message me demandent quelle colonne je dois prendre.

La fonction InputBox permet cela ou encore la méthode Application.InputBox

**rMist2024** · 18/06/2025, 11h39

J'ai ajouté Application.InputBox qui demande la colonne contenant les nouveaux noms
Le code accepte les colonnes B, C ou D tu peux ajuster cette ligne selon le besoin.

If UCase(ColonneSource) Like "[BCD]" Then Exit Do

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
Sub ChangerNoms()
Dim i As Long, nPos As Long
Dim Dic As New Collection
Dim nName As String, nNew As String, Ext As String
Dim oDossier, oFile, fso As Object
Dim ColonneSource, nNdr As Long
 
oDossier = "C:\Users\pc\Desktop\fld"
Do
    ColonneSource = Application.InputBox("Entrer la colonne source", Type:=2) 'Demande le nom de la colonne source
    If VarType(ColonneSource) = vbBoolean Then 'si rien n'a été saisi l'opération est annulée
       Exit Sub
    End If
    If UCase(ColonneSource) Like "[BCD]" Then Exit Do
Loop
With Worksheets("Feuil1")
  For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row  'Place les noms dans colonne A dans le dico
      nName = Left(.Cells(i, "A"), 7)
      Dic.Add i, UCase(nName)
  Next
 
  Set fso = CreateObject("Scripting.Filesystemobject")
  For Each oFile In fso.GetFolder(oDossier).Files
     nName = fso.GetBaseName(oFile.Name)
     nName = Left$(nName, 7)
     On Error Resume Next
     nPos = Dic(UCase(nName)) 'vérifie la présence du nom du fichier dans le dico
     If Err.Number = 0 Then 'Nom trouvé
        Ext = fso.GetExtensionName(oFile.Name)
        If Ext <> "" Then: Ext = "." & Ext
        nNew = oFile.ParentFolder & "\" & .Cells(nPos, ColonneSource) & Ext
        oFile.Move nNew 'renommer le fichier
        nNdr = nNdr + 1
     Else
         Err.Clear
     End If
     On Error GoTo 0
  Next
End With
MsgBox nNdr & "  Fichier mis à jour"
End Sub

**Anthonydu62** · 18/06/2025, 12h06

Merci, Merci, Merci

Changer nom de fichier pdf suivant tableau excel.

Macros et VBA Excel

Discussions similaires

Partager

Partager