XL 2016 [VBA] Création Arborescence

[Hayholten]

Salut à tous !

Je viens vers vous pour réussir à automatiser une tâche bien pénible au quotidien.

Nous gérons au fil de l'année des projets qui sont stockés dans des répertoires sur un serveur selon une arborescence donnée. Dans un fichier Excel de suivi, je crée une ligne par projet et tout un tas d'informations relatifs à ce dernier. J'ai également dans une colonne une formule de concaténation doublée avec une fonction de lien hypertexte afin d'accéder au dossier du projet en un clic.

Mon but vous l'aurez compris, serait de créer par un simple clic sur un bouton affecté à une macro les répertoires et sous répertoires en question.

Seulement, je suis une quiche en VBA (évidemment)... J'ai trouvé des codes ici et là mais ne sachant pas réellement les lire, je pédale dur dans le vide. Un exemple :

https://excel-malin.com/codes-sources-vba/creation-dossiers-et-sous-dossiers-en-vba/

Je joins un fichier que j'ai créé pour vous donner une idée de ce que je cherche à faire (mon fichier original qui contient beaucoup de données confidentielles est bien plus chargé en informations mais si je choppe la logique, je devrai pouvoir m'adapter).

Je vous remercie par avance pour l'aide apportée, en espérant avoir été le plus clair possible.

À vite

 

[BOISGONTIER]

Bonjour,

Un exemple de création d'arborescence

http://boisgontierjacques.free.fr/fichiers/Cellules/ArborescenceREP.xls

Boisgontier

 

[Hayholten]

Hello @BOISGONTIER

Merci pour ta réponse. Je vais décortiquer le code et voir comment je peux l'adapter à mes besoins (c'est pas intuitif pour moi encore tout ça).

C'est une question de lecture mais merci pour ton aide

 

[Hayholten]

J'ai aussi trouvé ce code, qui me semble plus simple :

Sub test()

    Dim strPath  As String
    Dim lCtr     As Long

    strPath = "C:\Temp\"

    arrpath = Split(strPath, "\")
    strPath = arrpath(LBound(arrpath)) & "\"

    For lCtr = LBound(arrpath) + 1 To UBound(arrpath)
        strPath = strPath & arrpath(lCtr) & "\"          
        If Dir(strPath, vbDirectory) = "" Then
            MkDir strPath
        End If
    Next

End Sub

En revanche, je suis infoutu de savoir comment j'indique à la fonction d'aller chercher dans une colonne donnée les chemins concaténés de mon arborescence type : "\\172.17.6.199\Projets\DPT Francophone\".

 

[Hayholten]

Celui me paraît sexy aussi (mais j'ai du mal à voir la différence) :/

Sub MakeFolder()

Dim strComp As String, strPart As String, strPath As String

strComp = Range("A1") ' assumes company name in A1
strPart = CleanName(Range("C1")) ' assumes part in C1
strPath = "C:\Images\"

If Not FolderExists(strPath & strComp) Then
'company doesn't exist, so create full path
    FolderCreate strPath & strComp & "\" & strPart
Else
'company does exist, but does part folder
    If Not FolderExists(strPath & strComp & "\" & strPart) Then
        FolderCreate strPath & strComp & "\" & strPart
    End If
End If

End Sub

Function FolderCreate(ByVal path As String) As Boolean

FolderCreate = True
Dim fso As New FileSystemObject

If Functions.FolderExists(path) Then
    Exit Function
Else
    On Error GoTo DeadInTheWater
    fso.CreateFolder path ' could there be any error with this, like if the path is really screwed up?
    Exit Function
End If

DeadInTheWater:
    MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again."
    FolderCreate = False
    Exit Function

End Function

Function FolderExists(ByVal path As String) As Boolean

FolderExists = False
Dim fso As New FileSystemObject

If fso.FolderExists(path) Then FolderExists = True

End Function

Function CleanName(strName as String) as String
'will clean part # name so it can be made into valid folder name
'may need to add more lines to get rid of other characters

    CleanName = Replace(strName, "/","")
    CleanName = Replace(CleanName, "*","")
    etc...

End Function