Boucle pour renommer dossiers

Bonsoir le forum

Je cherche par le biais d'une boucle la possibilité de renommer des dossiers en fonction des 4 derniers chiffres déjà contenu dans leur nom

Je reçois des dossiers contenant d'autres dossiers nommés tous plus ou moins différemment, la seule chose qui ne bouge jamais c'est les 4 derniers chiffres (ils changent tout le temps, mais j'ai toujours 4 chiffres)

ex: je peux recevoir pt 001234 ou Pt 1234, ou PT 01234.....

Je voudrais renommer ces dossier avec ce format : BP PT 001234, BP PT 001235... toujours BP PT les deux "00" et les 4 derniers chiffres déjà présent dans l'ancien nommage

Je place un dossier zipper avec des fichiers modèle

D'avance je vous remercie pour votre et votre disponibilité

Bonsoir,

Je n'ai pas ouvert ton fichier mais voici une piste à adapter à tes besoins. Dans la Sub() "Test" ci-dessous, il te faut adapter l'extension de tes fichiers et le chemin du dossier où ils se trouvent. Le renommage est fait de la manière suivante :

"BP PT 00123" & I & Extension

La racine, "BP PT 00123", est invariable

à laquelle est rajouté la valeur de I qui commence à 1 et est incrémentée de 1 puis l'extension (ici, dans mon exemple, .xls), adaptes :

Sub Test()

    Dim Tbl() As String
    Dim I As Integer
    Dim Chemin As String
    Dim Extension As String

    'adapter l'extension !
    Extension = ".xls"

    'adapter le chemin du dossier...
    Chemin = "D:\Dossier\"

    'appel de la fonction pour récupérer les noms des classeurs
    Tbl = EnumFichiers(Chemin, Extension & "*") 'astérisque si tous les fichiers Excel (.xls, .xlsx, .xlsm, etc...)

    'si initialisé (au moins 1 classeur)
    If Not (Not Tbl) Then

        'boucle sur le tableau
        For I = 1 To UBound(Tbl)

            Renommer Chemin & Tbl(I), Chemin & "BP PT 00123" & I & Extension '<-- I pour incrémenter

        Next I

    End If

End Sub

Sub Renommer(AncienNom As String, NouveauNom As String)

    'attention, le classeur doit être fermé pour pouvoir modifier son nom dans l'explorateur !
    'donc, ce code doit être dans un autre classeur

    On Error Resume Next
    Name AncienNom As NouveauNom

    If Err.Number <> 0 Then MsgBox "Erreur lors de renommage du fichier '" & AncienNom & "' !"

End Sub

Function EnumFichiers(Chemin As String, Extension As String) As String()

    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer

    'complète le chemin le cas échéant
    If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"

    'récupère seulement les fichiers Excel
    Fichier = Dir(Chemin & "*" & Extension)

    'boucle sur les fichiers du dossier
    Do While (Len(Fichier) > 0)

        I = I + 1

        ReDim Preserve TableauFichiers(1 To I)

        TableauFichiers(I) = Fichier

        Fichier = Dir()

    Loop

    'retourne le tableau des noms de fichiers
    EnumFichiers = TableauFichiers()

End Function

Bonjour le forum

Bonjour Theze et merci pour ton aide et ta disponibilité

le code que tu m'as déposé concerne le renommage des fichiers alors que je cherche à renommer des dossiers dans un dossier

Ce code peut-il être adapter?

Bonsoir,

Désolé, j'ai mal interprété ta question

Voici un code un peu plus simple avec l'objet FSO :

Sub Test()

    Dim FSO As Object
    Dim Dossier As Object
    Dim SousDossier As Object
    Dim Chemin As String
    Dim I As Integer

    'à adpater, dossier contenant les sous-dossiers à renommer
    Chemin = "D:\Dossier\"

    Set FSO = CreateObject("Scripting.FileSystemObject")

    'effectue un contrôle d'existance
    If FSO.FolderExists(Chemin) = False Then

        MsgBox "Le dossier portant ce nom n'existe pas !"
        Exit Sub

    End If

    'parcour la collection et renomme
    For Each SousDossier In FSO.GetFolder(Chemin).SubFolders

        I = I + 1
        'BP PT 00123 = racine, I est incrémenté de 1 à chaque fois !
        SousDossier.Name = "BP PT 00123" & I

    Next SousDossier

End Sub

Bonsoir le forum

Bonsoir Theze et désolé pour le retard

Je te remercie pour ton aide mais ce n'est pas tout à fait ce que je cherche à faire

En fait je reçois tout les jours des dossiers compresser qui me sont adresser par différentes personnes

Ces personnes nomment plus ou moins différemment les dossiers contenus dans les dossiers compresser

La seule référence dont je suis sur c'est les 4 derniers caractères des nommage qui correspondent à 4 chiffres

Ca il ne peuvent pas faire autrement que de les fournir

Ce qu je voudrais faire, c'est que pour chaque dossier que vais décompresser, renommer tous les dossiers contenus avec toujours au début "BP PT 00" puis les 4 chiffres contenus dans l'ancien nom

merci pour ton aide et ta disponibilité

Bonjour,

Et comme ça ?

Sub Test()

    Dim FSO As Object
    Dim Dossier As Object
    Dim SousDossier As Object
    Dim Chemin As String
    Dim Nom As String
    Dim I As Integer
    Dim Nombre As String

    'à adpater, dossier contenant les sous-dossiers à renommer
    Chemin = "D:\Dossier\"

    Set FSO = CreateObject("Scripting.FileSystemObject")

    'effectue un contrôle d'existance
    If FSO.FolderExists(Chemin) = False Then

        MsgBox "Le dossier portant ce nom n'existe pas !"
        Exit Sub

    End If

    'parcour la collection et renomme
    For Each SousDossier In FSO.GetFolder(Chemin).SubFolders

        'on récupère le nom avant modif
        Nom = SousDossier.Name

        'puis on extrait les chiffres pour en faire un nombre typé String
        For I = 1 To Len(Nom)

            If IsNumeric(Mid(Nom, I, 1)) Then Nombre = Nombre & Mid(Nom, I, 1)

        Next I

        'si un nombre a été extrait, on renomme sinon, rien !
        If Nombre <> "" Then SousDossier.Name = "BP PT 00" & Nombre

        'pour le suivant
        Nombre = ""

    Next SousDossier

End Sub

Bonsoir le forum

Bonsoir Theze merci pour ta disponibilité

Oui la c'est super ça fonctionne

Je te remercie beaucoup pour ton aide

c'est vraiment super je vais gagner du temps