XL 2016 Creation de dossier et sous dossier depuis Excel

[BenBenIS]

Bonjour le forum,

Avant tout, un grand merci a tout les gurus Excel qui nous aident et partagent leur expertise ! 🙏

Voila, je cherche a créer une longue arborescence dans explorer depuis Excel avec dossier et sous dossier.
Je pense que ça peut se faire via powershell mais mes compétences sont limitées.

Est-ce quelqu'un peut m'aider svp ?

Ci joint le fichier Excel en question.

Merci

 

[patricktoulon]

Bonjour à tout les deux
le code que j'ai utilisé pour la demo hier
c'est assez simple il suffit de combler les vides quand ils doivent l'être
ensuite une lecture lineaire(ligne par ligne) avec boucle sur colonne dans une boucle
on fait le test dir de la compilation des colonne à chaque fois et on fait un mkdir si le dir est negatif
je vous donne le code de demo d'hier

'efface ce qui est en rouge
Sub efface()
    Dim cel As Range
    With ActiveSheet.UsedRange
        For Each cel In .Cells
            If cel.Font.Color <> vbBlack Then cel.Value = ""
        Next
        .Font.Color = vbBlack
    End With
End Sub


Sub Comble_les_blancs()
    Dim lig&, c&, Nom$
    With ActiveSheet.UsedRange
        'le premier dossier  en colonne 1
        For i = 3 To .Cells(.Cells.Count).Row
            .Cells(i, 1) = .Cells(2, 1)
            .Cells(i, 1).Font.Color = vbRed
        Next
        'les dossier manquant dans le tableau
        For c = 2 To 6
            Nom = ""
            For lig = 2 To .Cells(.Cells.Count).Row
                If .Cells(lig, c) <> "" Then
                    Nom = .Cells(lig, c)
                Else
                    If .Cells(lig, c - 1) = Cells(lig - 1, c - 1) And .Cells(lig, c - 1) <> "" Then
                        .Cells(lig, c) = Nom
                        .Cells(lig, c).Font.Color = vbRed
                    End If
                End If
            Next
        Next
    End With
End Sub

'maintenant on peut lire ligne par ligne  et construire les dossiers et sous dossiers
'dans une boucle avec un test dir a chaque fois
Sub createfolder()
    Dim Tablo, i&, c&, chemin$
    Tablo = ActiveSheet.UsedRange.Value
    For i = 2 To UBound(Tablo)
        chemin = ThisWorkbook.Path 'adapter la racine ICI
        For c = 1 To UBound(Tablo, 2)
            If Tablo(i, c) <> "" Then chemin = chemin & "\" & Tablo(i, c)
            'If Dir(chemin, vbDirectory) = "" Then MkDir chemin     ' ligne à debloquer
        Next
        Debug.Print chemin
    Next
End Sub

A noter que je crée les dossiers et subdossiers dans une sub mais j'aurais très bien pu le faire dans la sub pour combler les blanc (toujours pareil avec un test dir )

Attention aux caractères speciaux dans les noms
ne pas oublier d'adapter la racine !!!

 

[patricktoulon]

re
si tu fait un replace des chemin sur le "/" par "_" tout les chemins passent

'maintenant on peut lire ligne par ligne  et construire les dossiers et sous dossiers
'dans une boucle avec un test dir a chaque fois
Sub createfolder()
    Dim Tablo, i&, c&, chemin$
    Tablo = ActiveSheet.UsedRange.Value
    For i = 2 To UBound(Tablo)
        chemin = ThisWorkbook.Path 'adapter la racine ICI
        For c = 1 To UBound(Tablo, 2)
            If Tablo(i, c) <> "" Then
                chemin = chemin & "\" & Tablo(i, c)
               chemin = Replace(chemin, "/", "_")
                If Dir(chemin, vbDirectory) = "" Then MkDir chemin ' ligne à debloquer
            End If
        Next
        Debug.Print chemin
    Next
End Sub

 

[patricktoulon]

Franchement, la structure de ton tableau était absolument parfaite (à part les lignes vides). 🤩

Depuis le temps que j'essayais de trouver une façon claire de représenter une arborescence de disque dur, j'ai enfin trouvé mon bonheur. 👍

Le fait que tu aies sauté une ligne à chaque nouveau niveau m'a permis de pondre un code relativement simple.

Bonjour @TooFatBoy
je te propose de faire l'inverse c'est a dire partir d'un disque ou dossier et créer le visuel dans la feuille

'******************************************
'fonction liste dossier  en recursif pour lister les  dossiers et sous dossiers d'un dossier ou disque racine
'auteur :patricktoulon
'date :03/07/2018
'avec un object collection pour relancer la récursivité avec la compilation des subfolder
'****************************************************************

Const maitre = "C:\Users\patricktoulon\Desktop\toto" 'adapter le chemin

Sub clearAll()
Cells.ClearContents
End Sub

Function FSO_List_DOSSIER(ByVal Folder As Variant) As Variant
    Static tbl() As String: Static NbDossiers As Long: Static oFSO As Object: Dim oDir As Object, oSubDir As Object, First_Call As Boolean
    If TypeOf Folder Is Object  Then
        First_Call = False: Set oDir = Folder
    Else
        First_Call = True: Erase tbl: NbDossiers = 0
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        If Right(Folder, 1) <> "\" Then Folder = Folder & "\"
        Set oDir = oFSO.getfolder(Folder)
    End If
    On Error Resume Next
    NbDossiers = NbDossiers + 1: ReDim Preserve tbl(1 To NbDossiers): tbl(NbDossiers) = oDir.path
    For Each oSubDir In oDir.subfolders
        If Err.Number = 0 Then
            FSO_List_DOSSIER oSubDir
            Else: Err.Clear
        End If
    Next oSubDir
    On Error GoTo 0
    If First_Call Then
        FSO_List_DOSSIER = False
        If NbDossiers > 0 Then FSO_List_DOSSIER = tbl
    End If
End Function

Sub Test()
    clearAll
  
    tabl = FSO_List_DOSSIER(maitre)
    
    Cells(2, 1).Resize(UBound(tabl), 1) = Application.Transpose(tabl)

    MsgBox "La liste des dossier est faite en colonne 1" & vbCrLf & " séparation des segmentS DES pathS en colonne", vbOKOnly

    Columns("A:A").TextToColumns Destination:=Range("A:A"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, Other:=True, OtherChar _
             :="\", TrailingMinusNumbers:=True

    MsgBox "suppression des noms en doublon pour mettre en 2vidence l'indentation de l'arborescence", vbOKOnly

    With ActiveSheet.UsedRange
        For c = 1 To .Cells(.Cells.Count).Column
            For l = .Cells(.Cells.Count).Row To 2 Step -1
                If .Cells(l, c) = .Cells(l - 1, c) Then .Cells(l, c) = ""
            Next
        Next
    .EntireColumn.AutoFit
    End With
End Sub

 

[BenBenIS]

Franchement, la structure de ton tableau était absolument parfaite (à part les lignes vides). 🤩

Depuis le temps que j'essayais de trouver une façon claire de représenter une arborescence de disque dur, j'ai enfin trouvé mon bonheur. 👍

Le fait que tu aies sauté une ligne à chaque nouveau niveau m'a permis de pondre un code relativement simple.

You guys rock !! J'ai modifie le numbering des dossiers avec NotePad++ et c'est nickel. Mille merci. Le gain de temps est juste monstrueux