subcarpetas - macro para importar nombres de carpetas a excel

¿Hay una manera de crear una carpeta y subcarpetas en Excel VBA?

Question

Ok, para aquellos que saben que son maestros en Excel VBA, tengo un menú desplegable de compañías que se rellena con una lista en otra pestaña. Tres columnas, Compañía, Número de trabajo y Número de pieza.

Lo que estoy haciendo es que cuando se crea un trabajo necesito una carpeta para la creación de dicha compañía, y luego una subcarpeta creada en base a dicho Número de parte. Así que si vas por el camino se vería así:

C:/Images/Company Name/Part Number/

Ahora bien, si existe el nombre de la empresa o el número de pieza, no cree, o sobrescriba el anterior. Solo ve al siguiente paso. Entonces, si ambas carpetas existen, no pasa nada, si una o ambas no existen, crea según sea necesario.

¿Esto tiene sentido?

Si alguien me puede ayudar a comprender cómo funciona esto y cómo hacer que funcione, sería muy apreciado. Gracias de nuevo.

Otra pregunta si no es demasiado, ¿hay alguna forma de hacerlo para que funcione en Mac y PC de la misma manera?

Answer 1

Aquí hay un sub breve sin manejo de errores que crea subdirectorios:

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

Answer 2

Encontré una forma mucho mejor de hacer lo mismo, menos código, mucho más eficiente. Tenga en cuenta que "" "" es para indicar la ruta en caso de que contenga espacios en blanco en el nombre de una carpeta. La línea de comandos mkdir crea cualquier carpeta intermedia si es necesario para que exista toda la ruta.

If Dir(YourPath, vbDirectory) = "" Then
Shell ("cmd /c mkdir """ & YourPath & """")
End If

Answer 3

Esto funciona como un encanto en AutoCad VBA y lo tomé de un foro de Excel. No sé por qué todos ustedes lo hacen tan complicado?

PREGUNTAS FRECUENTES

Pregunta: No estoy seguro si un directorio en particular ya existe. Si no existe, me gustaría crearlo utilizando el código VBA. ¿Cómo puedo hacer esto?

Respuesta: Puede hacer una prueba para ver si existe un directorio utilizando el siguiente código de VBA:

(Las citas a continuación se omiten para evitar la confusión del código de programación)

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

Answer 4

Hay algunas respuestas buenas aquí, así que solo agregaré algunas mejoras de proceso. Una mejor manera de determinar si la carpeta existe (no usa FileSystemObjects, que no todas las computadoras pueden usar):

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

Igualmente,

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

Answer 5

Nunca lo intenté con sistemas que no sean Windows, pero aquí está el que tengo en mi biblioteca, bastante fácil de usar. No se requiere una referencia especial de la biblioteca.

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

Answer 6

Otra versión sencilla que funciona en 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

Answer 7

Sé que esto ha sido respondido y que ya hubo muchas respuestas buenas, pero para las personas que vienen aquí y buscan una solución, yo podría publicar lo que finalmente he acordado.

El siguiente código maneja ambas rutas a una unidad (como "C: / Users ...") y a una dirección de servidor (estilo: "/ Server / Path .."), toma una ruta como argumento y elimina automáticamente cualquier ruta nombre de archivo (use "/" al final si ya es una ruta de directorio) y devuelve falso si por alguna razón no se pudo crear la carpeta. Ah, sí, también crea subdirectorios secundarios, si se solicitó.

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

Espero que alguien pueda encontrar esto útil. ¡Disfrutar! :-)

Answer 8

Una sub y dos funciones. El subgrupo construye su ruta y usa las funciones para verificar si la ruta existe y crear si no. Si el camino completo ya existe, simplemente pasará. Esto funcionará en la PC, pero también tendrá que comprobar qué se debe modificar para que funcione en 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

Answer 9

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

Answer 10

 Sub MakeAllPath(ByVal PS$)
Dim PP$
If PS <> "" Then
'' chop any end name
PP = Left(PS, InStrRev(PS, "/") - 1)
'' if not there so build it
If Dir(PP, vbDirectory) = "" Then
MakeAllPath Left(PP, InStrRev(PS, "/") - 1)
'' if not back to drive then build on what is there
If Right(PP, 1) <> ":" Then MkDir PP
End If
End If

End Sub