Création des dossiers et sous-dossiers en VBA 13

 dans Codes sources VBA  étiqueté Gestion des fichiers / Système / Windows (mis à jour le )

Si vous avez besoin de créer un nouveau dossier avec VBA, vous pouvez utiliser le code qui suit. Son grand avantage par rapport à la plupart des solutions qui circulent sur internet réside dans le fait qu’il peut créer non seulement un nouveau dossier mais également ses sous-dossiers.

Créer dossiers et sous-dossiers en VBA

Prenons un exemple pour illustrer la situation: Nous avons le dossier « C:\Temp » qui ne contient aucun sous-dossier.

Avec les codes habituels vous pouvez créer le dossier « C:\Temp\MonDossier » mais si vous voulez créer directement « C:\Temp\MonDossier\MonSousDossier » cela ne sera pas possible. La plupart des solutions ne peuvent pas créer des sous-dossiers dans un dossier qui n’existe pas encore.

Le code suivant peut créer des sous-dossiers dans des dossiers inexistants. Dans notre exemple, avec le code VBA sur cette page, la fonction va créer le dossier « C:\Temp\MonDossier » et ensuite le sous-dossier « MonSousDossier », tout cela dans une seule instruction.

Le nombre de niveaux de sous dossier n’est pas limité. Il s’agit donc d’une solution idéale pour créer des nouvelles structures complètes de dossiers et sous-dossiers.

07/01/2019
Suite à une remarque dans les commentaires, j’ai adapté le code pour qu’il fonctionne également sur les lecteurs en réseau (chemin du type “\\NomReseau\NomDossier\NomSousDossier”)…

Voici donc le code de la fonction prêt à l’emploi suivi d'un exemple d'utilisation.

Fonction VBA MkDir() pour créer un simple dossier

Pour créer un simple dossier, on peut se satisfaire de la fonction VBA de base MkDir() qui utilise un argument (de type String) qui contient le nom et l'emplacement du nouveau dossier. Le désavantage de cette fonction réside dans le fait qu'il est possible de créer un dossier seulement dans un dossier déjà existant.

MkDir("C:\Test\MonDossier1\")

Cette solution est suffisante si vous avez besoin d'ajouter un seul dossier. Simple et efficace.

Fonction VBA pour créer dossiers et sous-dossiers en même temps

Si, contrairement à l'exemple précédent, vous avez besoin de créer plusieurs niveaux de sous-dossiers, les fonctions de base de VBA ne seront pas suffisantes. Il vous faudra créer votre propre fonction. Ou plus simple: utiliser la fonction suivante…

Function CreerDossier(Chemin As String)
'par: Excel-Malin.com ( https://excel-malin.com )
    On Error GoTo CreerDossierErreur

Dim PremierDossier As String
Dim CheminReseau As Boolean
Dim CheminPartielOK As String
Dim CheminPartiel, PartieDeChemin As Integer
Dim PartiesDeChemin As Variant

Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")

If Len(Dir(Chemin, vbDirectory)) > 0 Then
CreerDossier = True
Exit Function
Else
        'suppression du dernier backslash si présent
        If Right(Chemin, 1) = Application.PathSeparator Then Chemin = Left(Chemin, Len(Chemin) - 1)
        
        'vérificacion si chemin local ou réseau
        If Left(Chemin, 2) = "\\" Then
            CheminReseau = True
        Else
            CheminReseau = False
        End If
        
        'décomposition du chemin
        If CheminReseau = False Then
            PartiesDeChemin = Split(Chemin, Application.PathSeparator)
            CheminPartielOK = ""
            PremierDossier = LBound(PartiesDeChemin)
        Else
            PartiesDeChemin = Split(Replace(Chemin, "\\", ""), Application.PathSeparator)
            CheminPartielOK = ""
            PremierDossier = LBound(PartiesDeChemin) + 1
        End If
    
    'tests et créations de (sous)dossiers
        For PartieDeChemin = PremierDossier To UBound(PartiesDeChemin)

            For CheminPartiel = LBound(PartiesDeChemin) To PartieDeChemin
            
                        If CheminReseau = False Then
                            CheminPartielOK = CheminPartielOK & PartiesDeChemin(CheminPartiel) & Application.PathSeparator
                        Else
                            CheminPartielOK = CheminPartielOK & PartiesDeChemin(CheminPartiel) & Application.PathSeparator
                        End If

                If CheminPartiel = PartieDeChemin Then
                        If CheminReseau = False Then
                                    If FSO.FolderExists(CheminPartielOK) = False Then
                                            MkDir CheminPartielOK
                                    End If
                        Else
                                    If Right(CheminPartielOK, 1) = Application.PathSeparator Then _
                                    CheminPartielOK = Left(CheminPartielOK, Len(CheminPartielOK) - 1)
                                    
                                    If Left(CheminPartielOK, 2) <> "\\" Then _
                                    CheminPartielOK = "\\" & CheminPartielOK
                                    
                                    If FSO.FolderExists(CheminPartielOK) = False Then
                                            MkDir CheminPartielOK
                                    End If
                        End If
                End If
            Next CheminPartiel
            CheminPartielOK = ""
        Next PartieDeChemin
End If

CreerDossier = True
Exit Function
CreerDossierErreur:
CreerDossier = False
End Function

Exemple d'utilisation de la fonction VBA

Voici donc un code VBA qui utilise la fonction que je vous propose plus haut pour créer un dossier (MonDossier) ainsi que des sous-dossier en 3 niveaux. Tout cela crée dans le dossier "Temp" qui se trouve sur le disque C: .

 Comme vous pouvez le voir, cela peut difficilement être plus simple et plus "user-friendly"!

Sub ExempleCreationDossierAvecSousdossiers()
'par: Excel-Malin.com ( https://excel-malin.com )
    On Error GoTo ExempleErreur

Dim NouveauDossierAvecSousDossiers As String
    NouveauDossierAvecSousDossiers = "C:\Temp\MonDossier\MonSousDossier\Niveau_3\Niveau_4"
    CreerDossier (NouveauDossierAvecSousDossiers)
Exit Sub
ExempleErreur:
    MsgBox "Une erreur est survenue..."
End Sub

Ceci devrait rendre votre travail plus rapide et plus efficace. Que ce soit un simple classement de fichiers ou la création d'une application VBA.

Pour aller plus loin en Excel et en VBA

80 0

 



Laissez un commentaire

Votre adresse de messagerie ne sera pas publiée.

13 commentaires sur “Création des dossiers et sous-dossiers en VBA”

  • Répondre ↓
    Sauvegarde a la fermeture Dans Autre Dossier

    Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim fl1 As String, fl2 As String, fl3 As String, fl4 As String, w1 As String, w2 As String, w3 As Workbook
    Application.ScreenUpdating = False
    w1 = ThisWorkbook.FullName ' Fichier Original
    w2 = ThisWorkbook.Name ' "ABC.xlsm"
    Set w3 = ThisWorkbook ' ThisWorkbook "C:\Documents and Settings\NomUtilisateur\Mes documents"
    fl2 = "\" ' "\"
    fl1 = fl2 & "Sauv" ' \Sauv
    fl3 = fl2 & Format(Now, "yy-mm-dd") ' "\Date Du Jour"
    fl4 = fl2 & Left(w2, (InStrRev(w2, ".") – 1)) ' "\ABC" Only ABC from ABC.xlsm
    ' myName = Left (ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".") – 1))
    ' ext = Right(ThisWorkbook.Name, Len(ThisWorkbook.Name) – InStrRev(ThisWorkbook.Name, "."))
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:= _
    w3.Path & fl2 & w2, FileFormat:=xlOpenXMLWorkbookMacroEnabled, AccessMode:=xlShared 'w3.Path sauvegarde même dossier
    If Dir(w3.Path & fl1, 16) = "" Then
    MkDir (w3.Path & fl1)
    MkDir (w3.Path & fl1 & fl3 & "")
    MkDir (w3.Path & fl1 & fl3 & fl4)
    ElseIf Dir(w3.Path & fl1 & fl3 & "", 16) = "" Then
    MkDir (w3.Path & fl1 & fl3 & "")
    MkDir (w3.Path & fl1 & fl3 & fl4)
    ElseIf Dir(w3.Path & fl1 & fl3 & fl4, 16) = "" Then
    MkDir (w3.Path & fl1 & fl3 & fl4)
    End If
    ActiveWorkbook.SaveAs Filename:= _
    w3.Path & fl1 & fl3 & fl4 & fl2 & Format(Now, "hhnnss") & "_" & w2, FileFormat:= _
    xlOpenXMLWorkbookMacroEnabled, AccessMode:=xlShared '\Sauv sauvegarde dans un autre dossier
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    End Sub

  • Répondre ↓
    Soignisec

    Superbe solution pour le fondement d'une copie avec création de dossiers multiples.

    Voici une version qui ne modifie Chemin que j'ai renommé CheminTemp et avec déclaration des variables :

    Option Explicit

Function CreerDossier(CheminTemp As String)
'par: Excel-Malin.com ( https://excel-malin.com )
    On Error GoTo CreerDossierErreur
Dim Chemin As String
Chemin = CheminTemp

Dim PartiesDeChemin() As String
Dim PartieDeChemin As Integer, CheminPartiel As Integer
Dim CheminPartielOK As String

If Len(Dir(Chemin, vbDirectory)) > 0 Then
CreerDossier = True
Exit Function
Else
        If Right(Chemin, 1) = Application.PathSeparator Then Chemin = Left(Chemin, Len(Chemin) - 1)
        PartiesDeChemin = Split(Chemin, Application.PathSeparator)

        For PartieDeChemin = LBound(PartiesDeChemin) To UBound(PartiesDeChemin)

            For CheminPartiel = LBound(PartiesDeChemin) To PartieDeChemin
                CheminPartielOK = CheminPartielOK & PartiesDeChemin(CheminPartiel) & Application.PathSeparator
                If CheminPartiel = PartieDeChemin Then
                    If Len(Dir(CheminPartielOK, vbDirectory)) = 0 Then
                        MkDir CheminPartielOK
                    End If
                End If
            Next CheminPartiel
            CheminPartielOK = ""
        Next PartieDeChemin
End If

CreerDossier = True
Exit Function
CreerDossierErreur:
CreerDossier = False
End Function
  • Répondre ↓
    Guillaume

    Bonjour,
    J'ai utilisé votre fonction, pour créer plusieurs répertoires et sous répertoires selon une boucle.

    Je ne sais pour quelle raison, mais le répertoire "racine" qu'elle a créé nécessite des droits admin si on veut pouvoir le supprimer par la suite.
    Savez vous comment est-ce possible? Est il possible de désactiver cette fonctionnalit2?

    Merci

    • Répondre ↓
      excel-malin.com Auteur de l’article

      Bonjour Guillaume,
      à vrai dire, je n'ai pas encore rencontré ce cas de figure.
      En tout cas, ce n'est pas une fonctionnalité de la macro. Cela doit être lié au setup de votre windows. Quel version d'Excel / Windows utilisez-vous?
      Cela se produit avec chaque dossier racine que vous avez crée ou seulement dans des cas spécifiques?

      Bàv, Martin

  • Répondre ↓
    Ethan

    Bonjour,

    Merci pour ce code, j'ai rencontre un souci aléatoirement on dirait.
    J'ai l'impression que lorsque mon lien du dossier est sous la forme C:\…. cela fonctionne mais par contre en réseau avec un lien \\nomreseau\dossier1\… ne fonctionne pas.

    Voici comment je défini le chemin :
    NouveauDossierAvecSousDossiers = ThisWorkbook.Path & FamilyFolder & "\" & MainSerialNumber
    CreerDossier (NouveauDossierAvecSousDossiers)

    Merci de votre aide

    • Répondre ↓
      excel-malin.com Auteur de l’article

      Bonjour Ethan,
      en effet, ce code n'était pas prévu pour l'utilisation avec des disques en réseau (il datait de l'époque où le travail en réseau n'était pas si répandu).
      J'ai donc décidé de refaire le code pour qu'il soit adapté à la situation actuelle…
      C'était plutôt "complexe" comme modification mais j'y suis arrivé 😉

      Vous trouverez donc le nouveau code dans l'article. Je l'ai testé et il fonctionne en réseau et en local.
      Cordialement, Martin

  • Répondre ↓
    Supercopain

    Bonjour, je suis très intéressé par ce code (création d'un sous dossier dans un dossier) mais je débute dans la programmation VBA, alors j'ai copié votre code dans un classeur, fonction et plus bas la macro j'ai ensuite modifié le chemin ou je veux le dossiers et le sous dossier, mais au lancement de la macro il ne se passe rien . (j'espère que je me suis bien exprimé)
    Cordialement

  • Répondre ↓
    Anonyme

    Bonjour,
    en complément avec Option Explicit :

    Dim PremierDossier As String
    Dim CheminReseau As Boolean
    Dim CheminPartielOK As String
    Dim CheminPartiel, PartieDeChemin As Integer
    Dim PartiesDeChemin As Variant

  • Répondre ↓
    PAMPHILE

    Bonjour,

    Intéressante comme fonction.
    Cependant, en essayant de l'utiliser, LIGNE 19 j'ai le message d'erreur de compilation suivant: "Membre de méthode ou de donnés introuvable."
    Devrais-je ajouté une librairie à mon projet.
    J'utilise Office 365.

    Cordialement.

    • Répondre ↓
      excel-malin.com Auteur de l’article

      Bonjour PAMPHILE,
      normalement, aucune référence particulière n'est nécessaire. Je viens de le tester en Office 365 sans référence et cela marche.

      Mais essayez tout de même de cocher la référence Microsoft Scripting Runtime. Si cela marche, pouvez vous me le confirmer? Ainsi je l'ajjouterai dans le tutoriel pour que les autres n'aient pas le même soucis.

      Cordialement, Martin