Macro pour renommer les fichiers contenus dans des sous-dossiers
Fermé
Shrek007
-
Modifié par Shrek007 le 24/11/2016 à 21:20
michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 - 25 nov. 2016 à 14:15
michel_m Messages postés 16603 Date d'inscription lundi 12 septembre 2005 Statut Contributeur Dernière intervention 16 décembre 2023 - 25 nov. 2016 à 14:15
A voir également:
- Macro pour renommer les fichiers contenus dans des sous-dossiers
- Renommer plusieurs fichiers - Guide
- Wetransfer gratuit fichiers lourd - Guide
- Macro word - Guide
- Macro logiciel - Télécharger - Organisation
- Renommer iphone - Guide
1 réponse
michel_m
Messages postés
16603
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
16 décembre 2023
3 303
Modifié par michel_m le 25/11/2016 à 14:16
Modifié par michel_m le 25/11/2016 à 14:16
Bonjour,
Non testé, si problème merci de m'envoyer 1 ou 2 fichiers.csv
le code
Michel
Non testé, si problème merci de m'envoyer 1 ou 2 fichiers.csv
Mettre lefichier sans données confidentielles en pièce jointe sur « mon-partage.fr »
et faire un clic droit-coller le raccourci dans votre message
le code
Option Explicit
'---------------------------------------------------------------
Function Nouveau_nom(Fich As String)
Dim Separe, Jour As String, Mois As String, Annee As String
Dim Liste_mois, Num_mois As String
'transformation du nom de ficjier format jjmmmmaaaa en aaaammjj
'sépare les éléments du nom de fichier
Separe = Split(Fich)
Jour = Format(Separe(2), "00")
Mois = LCase(Separe(3))
'détermination du numéro de mois avec nom de mois sans accent "é" et majuscule
If Mois = "février" Or Mois = "décembre" Then: Mois = Replace(Mois, "é", "e")
Liste_mois = Array("janvier", "fevrier", "mars", "avril", "mai", "juin", "juillet", "aout", "septembre", "octobre", "novembre", "decembre")
Num_mois = Format(Application.Match(Mois, Liste_mois, 0), "00")
Annee = Left(Separe(4), 4)
Nouveau_nom Annee & Num_mois & Jour & ".csv"
End Function
'-----------------------------------------------------------------------------------
Sub renommer_fichier()
Dim objShell As Object, objFolder As Object, oFolderItem As Object
Dim Chemin As String, Fich As String
Application.ScreenUpdating = False
'dossier voulu
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
On Error Resume Next
Set oFolderItem = objFolder.Items.Item
Chemin = oFolderItem.Path
If Chemin = "" Then Exit Sub
ChDir Chemin 'dossier des fichiers csv
Fich = Dir("*.csv")
While Fich <> ""
Name Fich As Nouveau_nom(Fich)
Fich = Dir
Wend
End Sub
Michel