crear carpetas desde excel

[gonz30]

Hola a tod@s,

¿Cómo puedo crear carpetas desde una columna Excel? Se deberían crear en el mismo directorio donde se encuentra el Excel.

Agradezco vuestra ayuda.

Saludos
Gonz

[3pies]

Aquí lo tienes:

Código:

Sub Crear_carpetas()
'Ocultamos el procedimiento
Application.ScreenUpdating = False
'llamamos al objeto FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
'pasamos a una variable, la ruta donde se encuentra el fichero de excel
'donde se está ejecutando este código
ruta = ActiveWorkbook.Path
'seleccionamos la primera celda que contiene los nombre de las
'carpetas (suponemos que es A4)
Range("A4").Select
'recorremos toda la columna, hasta que encuentre una fila vacía, y
'por cada fila con texto, crearemos una carpeta con el nombre de ese mismo texto
Do While Not IsEmpty(ActiveCell.Offset(0, 0))
    'si la carpeta no existe, entonces la creamos
    If Not fso.FolderExists(ruta & "\" & ActiveCell.Value) Then
        fso.CreateFolder (ruta & "\" & ActiveCell.Value)
    End If
    'pasamos a la fila siguiente, y volvemos a recorrer el bucle
    ActiveCell.Offset(1, 0).Select
Loop
'limpiamos el objeto
Set fso = Nothing
'Mostramos el procedimiento
Application.ScreenUpdating = True
End Sub

Salu2

[miglos]

He intentado ejecutar este script, pero me aparece "error 1004 en tiempo de ejecucion. Error definido por la aplicacion o el objeto".
Utilizo Excel 2007, probe guardándolo como xls, pero me aparece el mismo mensaje de error.
Lo que necesito es exactamente lo que ofrece esta macro, que recorra la columna indicada, hasta que encuentre una vacia, y vaya creando las carpetas con el contenido de cada celda si es que no ha sido creada previamente.
Las carpetas deben ser creadas en la misma ruta donde se encuentra el archivo excel.
Tambien probé con este codigo, pero solo me crea la primera carpeta(si es que el contenido de la celda no contiene espacios), no me recorre el resto de la columna.

Código:

Sub crea_carpetas() 

Dim Nom_Carpeta As String 
Nom_Carpeta = Range("A1").Value 
If Nom_Carpeta = "" Then 
MsgBox "Nombre Invalido." & Chr(13) & "Las carpetas no se crearán", vbOKOnly, "Error!!!" 
Exit Sub 
End If 

Dim Nom_SubCarpeta As String 
Nom_SubCarpeta = Range("A2").Value 
If Nom_SubCarpeta = "" Then 
MsgBox "Nombre Invalido." & Chr(13) & "Las carpetas no se crearán", vbOKOnly, "Error!!!" 
Exit Sub 
End If 

On Local Error Resume Next 
MkDir "C:\" & Nom_Carpeta 
MkDir "C:\" & Nom_Carpeta & "\" & Nom_SubCarpeta 

End Sub

Gracias por su tiempo.

[Taribo007]

Y un compendio de las dos???

Sub Crear_carpetas()

'Ocultamos el procedimiento
Application.ScreenUpdating = False

'pasamos a una variable, la ruta donde se encuentra el fichero de excel
'donde se está ejecutando este código
ruta = ActiveWorkbook.Path
'seleccionamos la primera celda que contiene los nombre de las
'carpetas (suponemos que es A4)
Range("A4").Select
'recorremos toda la columna, hasta que encuentre una fila vacía, y
'por cada fila con texto, crearemos una carpeta con el nombre de ese mismo texto
Do While Not IsEmpty(ActiveCell.Offset(0, 0))
'si la carpeta no existe, entonces la creamos
If Len(Dir(ruta & "\" & ActiveCell.Value, vbDirectory)) = 0 Then
MkDir ruta & "\" & ActiveCell.Value
End If
'pasamos a la fila siguiente, y volvemos a recorrer el bucle
ActiveCell.Offset(1, 0).Select
Loop
'Mostramos el procedimiento
Application.ScreenUpdating = True
End Sub

Un saludo

[miglos]

Hola Taribo007:

Gracias por tu ayuda. He intentado aplicar lo que sugieres, pero me sigue apareciendo el mismo mensaje de error:

Código:

Se ha producido el error "1004" en tiempo de ejecución: 
Error definido por la aplicación o el objeto

Según indican, ese error puede deberse a la versión de Excel?
Ejecutando el paso a paso, indica que el error esta en la linea:

Código:

Do While Not IsEmpty(ActiveCell.Offset(0, 0))

[miglos]

Bueno, hasta el momento me funciona correctamente este código:

Código:

Sub Crea_Carpetas()
ruta = ActiveWorkbook.Path
   While ActiveCell.Value <> ""
      ActiveCell.Offset(1, 0).Range("A1").Select
      Nombre = ActiveCell.Value
      MkDir ruta & "\" & Nombre
   Wend
End Sub

Al menos cumple básicamente con lo que necesito.
Pero, y si quisiera que el nombre de la carpeta se forme de los valores de 2 celdas contiguas (A2-B2 , A3-B3, etc)?
Otra cosa, cuando encuentra un codigo igual, no continua creando el resto de carpetas y aparece un mensaje "Se ha producido el error 75 en tiempo de ejecución".

Adicionalmente, si quisiera que al final de la ejecución, me muestre un mensaje:
"Se han creado XX carpetas", como haria, intente con un contador de la siguiente manera:

Código:

Sub Crea_Carpetas()
contador = 0
ruta = ActiveWorkbook.Path

   While ActiveCell.Value <> ""
      ActiveCell.Offset(1, 0).Range("A1").Select
      Nombre = ActiveCell.Value
      MkDir ruta & "\" & Nombre
      contador = contador + 1
   Wend
Respuesta = MsgBox("Se han creado " & contador & " carpetas", 1, "Creación de Carpetas")
End Sub

Pero no llega a mostrar el mensaje. Aparentemente me falta controlar el fin de la ejecución.

Agradezco la ayuda que me puedan dar.

[miglos]

Finalmente conseguí lo que necesitaba. No he hecho muchas pruebas(por espacios en blanco o cosas asi), pero está bastante mejorado en relación al inicial.
Haciendo un par de validaciones, se puede agregar la opción de crear subcarpetas...y en fin, lo dejo aqui por si a alguien le es de utilidad.

Gracias a los codigos de 3pies y Taribo007 que sirvieron de modelo!

Código:

Sub Crear_carpetas()
Application.ScreenUpdating = False
contador = 0
Set fso = CreateObject("Scripting.FileSystemObject")
ruta = ActiveWorkbook.Path
Range("A2").Select
Do While Not IsEmpty(ActiveCell)
    Item = ActiveCell.Value
    If Len(Item) = 1 Then
        Item = "0" & Item
    End If
    ActiveCell.Offset(0, 1).Select
    Codigo = ActiveCell.Value
    ActiveCell.Offset(0, 1).Select
    Nombre = ActiveCell.Value
    Carpeta = Item & "-" & Codigo & "-" & Nombre
    If Not fso.FolderExists(ruta & "\" & Carpeta) Then
        fso.CreateFolder (ruta & "\" & Carpeta)
        contador = contador + 1
    End If
    ActiveCell.Offset(1, -2).Select
Loop
Respuesta = MsgBox("Se han creado " & contador & " carpetas", 64, "Número de Carpetas")
Set fso = Nothing
Application.ScreenUpdating = True
End Sub