Macro pour renommer des classeurs excel .xls grace à une liste de données

**marloh** · 03/08/2017, 20h42

salut, quelqu'un pourrait m'aider car je suis novice?
je souhaiterais renommer des classeurs excel .xls grâce à un tableau de 2 colonnes A et B se trouvant sur la feuille 3 de mon classeur. la colonne A contient les codes de batiment et la colonne B, les noms de maison. les classeurs sont nommés par les codes.
je souhaiterais remplacer les noms initiaux des classeurs qui sont des codes par les noms de la colonne B.
en claire, c'est une correspondance que je veux faire pour avoir les noms veritables sur le classeur.
c'est vraiment urgent!
je bute dessus depuis des jours. voici le dernier code essayer

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sheets("Feuil3").Select
    Dim LastRow2 As Long
    Dim k As Long
    LastRow2 = Range("B" & Rows.Count).End(xlDown).Row
 
    For k = 2 To LastRow2
 
    Dim AncienNom As String, NouveauNom As String
    AncienNom = "C:\Users\4528\Documents\INFORMATION CLIENT DANS DELTA\decoupe\" & Range("A" & k)
    NouveauNom = "C:\Users\4528\Documents\INFORMATION CLIENT DANS DELTA\decoupe\" & Range("B" & k)
    On Error Resume Next
    Name AncienNom As NouveauNom
    If Err = 75 Then Exit Sub
    Next k

**Roiser** · 04/08/2017, 12h14

Salut

J'ai pas testé mais ça devrait être bon :

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
 
 
Sub RenommerClasseur()
 
    Sheets("Feuil3").Select
    Dim LastRow2 As Long
    Dim k As Long
    Dim AncienNom As String
    Dim NouveauNom As String
    LastRow2 = Range("B" & Rows.Count).End(xlDown).Row
 
    For k = 2 To LastRow2
 
        AncienNom = "C:\Users\4528\Documents\INFORMATION CLIENT DANS DELTA\decoupe\" & Range("A" & k)
        NouveauNom = "C:\Users\4528\Documents\INFORMATION CLIENT DANS DELTA\decoupe\" & Range("B" & k)
 
        If Dir(fichier, vbNormal) = "" Then
            FileCopy AncienNom, NouveauNom
            On Error Resume Next
            Kill AncienNom
            On Error GoTo 0
        Else
            MsgBox "Fichier introuvable"
        End If
     Next k
 
End Sub