Macro VBA pour création dossiers en automatique

Bonjour à tous,

J'en appelle à votre expertise !

Je désire créer en automatique un ensemble de dossiers dans un emplacement réseau.

Je me suis servi, cf PJ, d'un classeur excel composé d'une macro qui fonctionne plutôt bien pour créer :

Dossiers N

Dossiers N-1

Dossiers N-1

Je souhaiterais la modifier pour pouvoir plus de dossiers dans le niveau N-1 :

Mikael

Serait-il possible de m'apporter une aide sur ce sujet ?

Bonne soirée,

Bonsoir Mike047,

Une proposition de code avec une méthode totalement différente :

Sub PropositionGVS()
    Const cRoot = "C:\Users\215902\Documents\GVS\EXCEL_PRATIQUE\MIKE047" 'A MODIFIER POUR INDIQUER l'EMPLACEMENT RESEAU
    Dim oFS As Object
    Dim oRow As Range
    Dim sFolder As String, sSubfolder1 As String, sSubfolder2 As String, sSubfolder3 As String
    Dim sSubfolder4 As String, sSubfolder5 As String, sSubfolder6 As String

    Set oFS = CreateObject("Scripting.FilesystemObject")

    For Each oRow In Sheets("Feuil4").UsedRange.Rows
        If oRow.Row > 1 And Len(Trim(oRow.Cells(1, 1).Value)) > 0 Then
            sFolder = cRoot & "\" & oRow.Cells(1, 1).Value
            If Not oFS.FolderExists(sFolder) Then
                oFS.CreateFolder sFolder
            End If
            sSubfolder1 = sFolder & "\" & oRow.Cells(1, 2).Value
            If Not oFS.FolderExists(sSubfolder1) Then
                oFS.CreateFolder sSubfolder1
            End If
            sSubfolder2 = sFolder & "\" & oRow.Cells(1, 3).Value
            If Not oFS.FolderExists(sSubfolder2) Then
                oFS.CreateFolder sSubfolder2
            End If
            sSubfolder3 = sFolder & "\" & oRow.Cells(1, 4).Value
            If Not oFS.FolderExists(sSubfolder3) Then
                oFS.CreateFolder sSubfolder3
            End If
            sSubfolder4 = sFolder & "\" & oRow.Cells(1, 5).Value
            If Not oFS.FolderExists(sSubfolder4) Then
                oFS.CreateFolder sSubfolder4
            End If
            sSubfolder5 = sFolder & "\" & oRow.Cells(1, 6).Value
            If Not oFS.FolderExists(sSubfolder5) Then
                oFS.CreateFolder sSubfolder5
            End If
            sSubfolder6 = sFolder & "\" & oRow.Cells(1, 7).Value
            If Not oFS.FolderExists(sSubfolder5) Then
                oFS.CreateFolder sSubfolder5
            End If
        End If
    Next

End Sub

Bonjour Gérard,

Je te remercie pour ton retour, mais pour gagner du temps, je souhaiterai rester sur ma structure actuelle.

Uniquement modifier la VBA existante de manière à rajouter des sous-dossiers.

Est-ce possible ?

En tout cas, merci d'avoir pris du temps à me répondre!

Bonne fin de journée,

Mikael

Gérard,

Finalement aucun grand chamboulement et ca marche très bien !

Merci beaucoup !