web-dev-qa-db-fra.com

Est-il possible de créer un dossier et des sous-dossiers dans Excel VBA?

Ok, pour ceux qui sont au courant qui sont maîtres dans Excel VBA, j'ai un menu déroulant des entreprises qui est rempli par une liste sur un autre onglet. Trois colonnes, Société, Numéro de travail et Numéro de pièce. 

Ce qui me manque, c'est que lorsqu'un travail est créé, j'ai besoin d'un dossier pour la création de ladite société, puis d'un sous-dossier créé à partir dudit numéro de pièce. Donc, si vous suivez le chemin, cela ressemblera à ceci:

C:\Images\Company Name\Part Number\

Maintenant, si le nom de la société ou le numéro de pièce existe, ne créez pas, ni écrasez l'ancien. Allez juste à l'étape suivante. Ainsi, si les deux dossiers existent, rien ne se passe, si l'un d'eux ou les deux n'existent pas, créez-les comme vous le souhaitez. 

Est-ce que ça a du sens? 

Si quelqu'un pouvait m'aider à comprendre comment cela fonctionne et comment le faire fonctionner, cela serait grandement apprécié. Merci encore.

Une autre question, si ce n'est pas trop, y a-t-il un moyen de le faire pour qu'il fonctionne de la même manière sur les Mac et les PC?

excelvbaexcel-vbaexcel-vba-mac
20
Matt Ridge

Un sous et deux fonctions. Le sous-marin construit votre chemin et utilise les fonctions pour vérifier si le chemin existe et créer si non. Si le chemin complet existe déjà, il passera simplement par . Cela fonctionnera sur PC, mais vous devrez vérifier ce qui doit être modifié pour fonctionner également sur Mac.

'requires reference to Microsoft Scripting Runtime
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
25
Scott Holtzman

Une autre version simple fonctionnant sur PC:

Sub CreateDir(strPath As String)
    Dim Elm As Variant
    Dim strCheckPath As String

    strCheckPath = ""
    For Each Elm In Split(strPath, "\")
        strCheckPath = strCheckPath & Elm & "\"
        If Len(Dir(strCheckPath, vbDirectory)) = 0 Then MkDir strCheckPath
    Next
End Sub
27
Martin

J'ai trouvé un moyen bien meilleur de faire la même chose, moins de code, beaucoup plus efficace. Notez que le "" "" est de citer le chemin s'il contient des espaces dans un nom de dossier. La ligne de commande mkdir crée un dossier intermédiaire si nécessaire pour que le chemin complet existe.

If Dir(YourPath, vbDirectory) = "" Then
    Shell ("cmd /c mkdir """ & YourPath & """")
End If
8
Leandro Jacques
Private Sub CommandButton1_Click()
    Dim fso As Object
    Dim tdate As Date
    Dim fldrname As String
    Dim fldrpath As String

    tdate = Now()
    Set fso = CreateObject("scripting.filesystemobject")
    fldrname = Format(tdate, "dd-mm-yyyy")
    fldrpath = "C:\Users\username\Desktop\FSO\" & fldrname
    If Not fso.folderexists(fldrpath) Then
        fso.createfolder (fldrpath)
    End If
End Sub
4
Chandan Kumar

Il y a quelques bonnes réponses ici, donc je vais simplement ajouter quelques améliorations au processus. Une meilleure façon de déterminer si le dossier existe (n'utilise pas FileSystemObjects, ce que tous les ordinateurs ne sont pas autorisés à utiliser):

Function FolderExists(FolderPath As String) As Boolean
     FolderExists = True
     On Error Resume Next
     ChDir FolderPath
     If Err <> 0 Then FolderExists = False
     On Error GoTo 0
End Function

Également,

Function FileExists(FileName As String) As Boolean
     If Dir(FileName) <> "" Then FileExists = True Else FileExists = False
EndFunction
3
SandPiper

Cela fonctionne comme un charme dans AutoCad VBA et je l'ai attrapé à partir d'un forum Excel. Je ne sais pas pourquoi vous faites tous si compliqué?

QUESTIONS FRÉQUEMMENT POSÉES

Question: Je ne suis pas sûr si un répertoire particulier existe déjà. S'il n'existe pas, j'aimerais le créer avec du code VBA. Comment puis-je faire ceci?

Réponse: Vous pouvez tester l'existence d'un répertoire à l'aide du code VBA ci-dessous:

(Les citations ci-dessous sont omises pour éviter toute confusion du code de programmation)

If Len(Dir("c:\TOTN\Excel\Examples", vbDirectory)) = 0 Then

   MkDir "c:\TOTN\Excel\Examples"

End If

http://www.techonthenet.com/Excel/formulas/mkdir.php

2
Brett

Jamais essayé avec des systèmes autres que Windows, mais voici celui que j'ai dans ma bibliothèque, assez facile à utiliser. Aucune référence de bibliothèque spéciale requise.

Function CreateFolder(ByVal sPath As String) As Boolean
'by Patrick Honorez - www.idevlop.com
'create full sPath at once, if required
'returns False if folder does not exist and could NOT be created, True otherwise
'sample usage: If CreateFolder("C:\toto\test\test") Then debug.print "OK"
'updated 20130422 to handle UNC paths correctly ("\\MyServer\MyShare\MyFolder")

    Dim fs As Object 
    Dim FolderArray
    Dim Folder As String, i As Integer, sShare As String

    If Right(sPath, 1) = "\" Then sPath = Left(sPath, Len(sPath) - 1)
    Set fs = CreateObject("Scripting.FileSystemObject")
    'UNC path ? change 3 "\" into 3 "@"
    If sPath Like "\\*\*" Then
        sPath = Replace(sPath, "\", "@", 1, 3)
    End If
    'now split
    FolderArray = Split(sPath, "\")
    'then set back the @ into \ in item 0 of array
    FolderArray(0) = Replace(FolderArray(0), "@", "\", 1, 3)
    On Error GoTo hell
    'start from root to end, creating what needs to be
    For i = 0 To UBound(FolderArray) Step 1
        Folder = Folder & FolderArray(i) & "\"
        If Not fs.FolderExists(Folder) Then
            fs.CreateFolder (Folder)
        End If
    Next
    CreateFolder = True
hell:
End Function
0
Patrick Honorez

Je sais que cela a été répondu et qu'il y avait déjà beaucoup de bonnes réponses, mais pour les personnes qui viennent ici et cherchent une solution, je pourrais publier ce que j'ai réglé avec le temps.

Le code suivant gère les deux chemins d'accès à un lecteur (comme "C:\Utilisateurs ...") et à une adresse de serveur (style: "\ Serveur\Chemin .."), il prend un chemin en argument et supprime les noms de fichier de celui-ci (utilisez "\" à la fin s'il s'agit déjà d'un chemin de répertoire) et renvoie false si, pour une raison quelconque, le dossier n'a pas pu être créé. Oh oui, il crée également des sous-sous-sous-répertoires, si cela était demandé.

Public Function CreatePathTo(path As String) As Boolean

Dim sect() As String    ' path sections
Dim reserve As Integer  ' number of path sections that should be left untouched
Dim cPath As String     ' temp path
Dim pos As Integer      ' position in path
Dim lastDir As Integer  ' the last valid path length
Dim i As Integer        ' loop var

' unless it all works fine, assume it didn't work:
CreatePathTo = False

' trim any file name and the trailing path separator at the end:
path = Left(path, InStrRev(path, Application.PathSeparator) - 1)

' split the path into directory names
sect = Split(path, "\")

' what kind of path is it?
If (UBound(sect) < 2) Then ' illegal path
    Exit Function
ElseIf (InStr(sect(0), ":") = 2) Then
    reserve = 0 ' only drive name is reserved
ElseIf (sect(0) = vbNullString) And (sect(1) = vbNullString) Then
    reserve = 2 ' server-path - reserve "\\Server\"
Else ' unknown type
    Exit Function
End If

' check backwards from where the path is missing:
lastDir = -1
For pos = UBound(sect) To reserve Step -1

    ' build the path:
    cPath = vbNullString
    For i = 0 To pos
        cPath = cPath & sect(i) & Application.PathSeparator
    Next ' i

    ' check if this path exists:
    If (Dir(cPath, vbDirectory) <> vbNullString) Then
        lastDir = pos
        Exit For
    End If

Next ' pos

' create subdirectories from that point onwards:
On Error GoTo Error01
For pos = lastDir + 1 To UBound(sect)

    ' build the path:
    cPath = vbNullString
    For i = 0 To pos
        cPath = cPath & sect(i) & Application.PathSeparator
    Next ' i

    ' create the directory:
    MkDir cPath

Next ' pos

CreatePathTo = True
Exit Function

Error01:

End Function

J'espère que quelqu'un trouvera cela utile. Prendre plaisir! :-)

0
Sascha L.

Voici un court sous-traitement sans erreur qui crée des sous-répertoires:

Public Function CreateSubDirs(ByVal vstrPath As String)
   Dim marrPath() As String
   Dim mint As Integer

   marrPath = Split(vstrPath, "\")
   vstrPath = marrPath(0) & "\"

   For mint = 1 To UBound(marrPath) 'walk down directory tree until not exists
      If (Dir(vstrPath, vbDirectory) = "") Then Exit For
      vstrPath = vstrPath & marrPath(mint) & "\"
   Next mint

   MkDir vstrPath

   For mint = mint To UBound(marrPath) 'create directories
      vstrPath = vstrPath & marrPath(mint) & "\"
      MkDir vstrPath
   Next mint
End Function
0
alexkovelsky