Ce genre de code doit toujours être manipulé avec précaution car celà va plus vite que de dire Ouf et sans alerte, et si on s'est planté de répertoire, ça peut faire un sacré sbinz !!! (imagine si tu fais tourner sous c:windows...)
Bon alors d'abord une Constante Public en Top de Module :
Code:
Option Explicit
Public Const ThePath As String = 'C:\\tes Fichiers\\le repertoire a traiter\\' '(à vérifier DEUX FOIS !!! LOL)
Ensuite je préfère procéder par une première étape de listing des fichiers qui vont être traités par le code TheRenamer, le code suivant va donc lister sur la feuille active tous les fichiers qui vont changer de nom :
Code:
Sub TheFileLister()
Dim TheFileSearcher As FileSearch
Dim I As Integer
On Error Resume Next
Set TheFileSearcher = Application.FileSearch
With TheFileSearcher
.NewSearch
.Filename = '*.xls*'
.LookIn = ThePath
.SearchSubFolders = False
.Execute msoSortByFileName, msoSortOrderAscending
If .Execute > 0 Then
With .FoundFiles
For I = 1 To .Count
Cells(I, 1).Value = ThePath & Dir(.Item(I))
Next I
End With
Else
MsgBox 'Pas de Fichier trouvé dans ' & ThePath
End If
End With
Set TheFileSearcher = Nothing
End Sub
Et dons enfin, une fois que l'on a vérifier la liste, TheRenamer peut entrer en action......... NB No way To Cancel, pas possible d'annnuler
Code:
Sub TheRenamer()
Dim WB As Workbook, WS As Worksheet
Dim OldName As String, NewName As String
Dim L As Integer, X As Integer
Set WB = ThisWorkbook
With WB
Set WS = .Sheets('List')
End With
L = WS.Range('A65536').End(xlUp).Row
For X = 1 To L
OldName = WS.Range('A' & X)
NewName = Right(OldName, Len(OldName) - 1 - Len(ThePath))
Name OldName As ThePath & NewName
Next X
End Sub
Merci Thierry
Effectivement c'est assez rapide et en plus la List me permet de la revérifier avant!!
Pour ceux qui vont la recopier il y a parcontre un ptit bug de points virgule et de guilmet:
Voici avec la correction et merci encore
Temjeh
Code:
Option Explicit
Public Const ThePath As String = 'C:\\Program Files....\\' '(à vérifier DEUX FOIS !!! LOL)
Sub TheRenamer()
Dim WB As Workbook, WS As Worksheet
Dim OldName As String, NewName As String
Dim L As Integer, X As Integer
Set WB = ThisWorkbook
With WB
Set WS = .Sheets('List')
End With
L = WS.Range('A65536').End(xlUp).Row
For X = 1 To L
OldName = WS.Range('A' & X)
NewName = Right(OldName, Len(OldName) - 1 - Len(ThePath))
Name OldName As ThePath & NewName
Next X
End Sub
Sub TheFileLister()
Dim TheFileSearcher As FileSearch
Dim I As Integer
On Error Resume Next
Set TheFileSearcher = Application.FileSearch
With TheFileSearcher
.NewSearch
.Filename = '*.xls*'
.LookIn = ThePath
.SearchSubFolders = False
.Execute msoSortByFileName, msoSortOrderAscending
If .Execute > 0 Then
With .FoundFiles
For I = 1 To .Count
Cells(I, 1).Value = ThePath & Dir(.Item(I))
Next I
End With
Else
MsgBox 'Pas de Fichier trouvé dans ' & ThePath
End If
End With
Set TheFileSearcher = Nothing
End Sub
Désolé de n'avoir répondu plus tôt, mais ce Forum est ingérable au niveau suivi de mes propres posts, je dois en faire trop !
Donc oui les ';' sont des 'parasites' venus se greffer dans la mise en forme du code, mais je te(vous) rassure, avant de publier un code je te le teste en réel toujours avant. mais c'est vrai que ce new Forum nous joue des tours.