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?
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
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
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
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
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
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
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
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! :-)
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