creation de dossier

[estivill]

Bonjour,
je souhaiterais créer suivant une liste des Dossier qui aurait pour intitulé la colonne A
et dans chacun 3 dossiers différents mais toujours les mêmes "DOSSIER 1 DOSSIER 2 DOSSIER 3"

l'arborescence dossier se créerait dans le dossier où est placé le fichier excel mais dans un dossier ARCHIVES

malgré mes recherche je n'ai pas trouver de quoi faire ni à adapter...

merci d'avance du temps que vous m'accorderez

 

[laurent3372]

Bonjour,

Voici une solution :

Option Explicit

' Crée le répertoire s'il n'existe pas
Private Declare PtrSafe Function SHCreateDirectoryEx _
    Lib "shell32" Alias "SHCreateDirectoryExA" _
    (ByVal hwnd As Long, ByVal pszsPath As String, ByVal psa As Any) As Long
 
Sub CréatonRépertoires(rngNoms As Range)
    Dim rNomDir As Range
    Dim sPath As String, sPathSubDir As String
    Dim i As Long
    
    sPath = ThisWorkbook.path & "\ARCHIVES"
    CreRep sPath
    For Each rNomDir In rngNoms
        sPathSubDir = sPath & "\" & rNomDir.Value
        CreRep sPathSubDir
        For i = 1 To 3
            CreRep sPathSubDir & "\Dossier " & i
        Next i
    Next rNomDir
    MsgBox "Répertoires créés"
End Sub

Sub CreRep(pPath As String)
    SHCreateDirectoryEx 0, pPath, ByVal 0&
End Sub

Attention: il faut ouvrir la pièce jointe et immédiatement l'enregistrer dans un répertoire de travail

Cordialement,
--
LR

 

[patricktoulon]

Bonjour

Option Explicit
Sub test()
   Dim Base$, I&, Sd&
   Base = ThisWorkbook.Path & "\ARCHIVE\"    'dossier racine a adapter
    If Dir(Base, vbDirectory) = "" Then MkDir Base    'creation du dossier racine si il existe pas
    For I = 3 To Cells(Rows.Count, 1).End(xlUp).Row 'boucle sur cellule "A"
        If Dir(Base & Cells(I, 1).Text & "\", vbDirectory) = "" Then 'test d 'existence du dossier en cells(i,"A")
            MkDir Base & Cells(I, 1).Text & "\" ' creation si il existe pas
            For Sd = 1 To 3 ' boucle de 1 a 3  et test si le dossier 1,2,3 existe ;si existe pas on le crée
                If Dir(Base & Cells(I, 1).Text & "\DOSSIER" & Sd & "\", vbDirectory) = "" Then MkDir Base & Cells(I, 1) & "\DOSSIER" & Sd
            Next Sd
        End If
    Next I
End Sub

 

[estivill]

merci à tout les deux vous avez géré et rapide en plus
j'ai pu adapter à mon fichier définitif

bonne journée

 

[laurent3372]

peux-tu marquer le fil comme résolu ?

 

[estivill]

yes c'est fait

 

[kiki29]

Salut, trop tard, à voir ici si curieux