Crear carpetas y subcarpetas con macro

Te paso la sub para crear mas carpetas

Sub IMPRIMIR()
Range("M7").Value = Now

'----------------------------------------------------------------------------------------------------TEXTO NUEVO
     Dim ruta As String
    ruta = "C:\Users\es07813894n\Documents"
    Call CreaNuevaCarpeta(ruta, Range("M119"))
    Call CreaNuevaCarpeta(ruta + "\" + Range("M119"), Range("M18"))  
'La ruta cambia
dim nueva_ruta as string

'La nueva ruta va en 1 sola linea

nueva_ruta="C:\Users\es07813894n\Documents\" + range("M119") + "\" + range("M118")

'------------------------------------------------------------------------------------------------------------------------------

CreaCarpeta nueva_ruta, Range("J118").Value ' Aqui todo igual pero con la ruta nueva
End Sub

'-----------------------------------------------------------------------------------------------------------------------------

Sub CreaNuevaCarpeta(ruta As String, NomCarpeta As String)

'Solo crea la carpeta

    If Dir(ruta, vbDirectory + vbHidden) <> "" Then
    If Dir(ruta & "\" & NomCarpeta, vbDirectory + vbHidden) = "" Then _
        MkDir ruta & "\" & NomCarpeta
    End If
End Sub

Hola Antares, lo primero agradecerte tu interés, y excusarme por mi tardanza, el trabajo me ha impedido ponerme en contacto contigo. Te aseguro que es por una causa buena, es el documento de una ONG para las entrevistas a personas muy necesitadas, bueno no te aburro con eso.

La verdad es que de programación no se nada, he ido cogiendo una cosa de aquí y otra de alla hasta llegar a la Macro que tengo, en ella el objetivo, primera linea, es poner la fecha y hora en la que se graba la entrevista, luego crear una carpeta con el nombre del año, dentro de esta otra con el nombre del mes y dentro de esta última otra con el nombre del día, para al final meter todas las entrevistas en esta última, obviamente no se puede "machacar" ningún archivo anterior. La macro termina imprimiendo 2 ó 3 archivos ocultos, dependiendo si hay justificación económica o no.

Te cuento todo esto para que sepas exactamente en lo que ando

Bueno, te diré que he intentado, con poco éxito, poner la Macro en funcionamiento, me pierdo con las rutas. No se si será muy osado por mi parte que me trascribas el código con la ruta, insisto soy torpe, pero en este momento me siento mas aún de lo normal.

Muchas gracias por todo

Desde Almería Manolo

¿No sería mejor crear la carpeta del año y del mes a mano?

Vaos a ver, en principio no habría problema, aunque bien es cierto que la carpeta va a un disco compartido y es mejor que no haya mucha gente que ande en el disco.

En cualquier caso, si hablamos de cosas bien echas lo suyo sería haber hecho la aplicación en Access, pero eso son otros cantares, a parte de que si en Excel estoy verde, en Access ni te cuento.

La idea es que el voluntario que hace la entrevista solo se preocupe de lo esencial, la atención al necesitado.

La función CrearNuevaCarpeta se queda igual

Una nueva función

Function ExisteCarpeta(ruta As String) As Boolean
    If Dir(ruta, vbDirectory + vbHidden) <> "" Then
        ExisteCarpeta= True
    Else
        ExisteCarpeta= False
    End If
End Function

'---------------------------------------------------------------------------------

Cambios en la sub de imprimir

Sub IMPRIMIR()
    Dim carpeta_creada As Boolean
    Dim carpeta_nuevo_archivo As Boolean
    Dim i As Integer
    With Hoja1 'Has de poner en que hoja están los datos
        .Range("M7").Value = Now
        i = 1
        carpeta_nuevo_archivo = True
    'TEXTO NUEVO
        Dim ruta As String
        ruta = "C:\Users\es07813894n\Documents"
        'Si existe la carpeta para elo año, si no hay la crea

        'Crear carpeta del año
        carpeta_creada = ExisteCarpeta(ruta + "\" + CStr(.Range("M119")))
        If (carpeta_creada = False) Then
            Call CreaNuevaCarpeta(ruta, .Range("M119"))
        End If
           'Crear la carpeta para el mes
        carpeta_creada = ExisteCarpeta(ruta + "\" + CStr(.Range("M119")) + "\" + CStr(.Range("M118")))
        If (carpeta_creada = False) Then Call CreaNuevaCarpeta(ruta + "\" + CStr(.Range("M119")), CStr(.Range("M118")))
        'La ruta cambia
        Dim nueva_ruta As String
        'La nueva ruta va en 1 sola linea
        nueva_ruta = "C:\Users\es07813894n\Documents" + "\" + CStr(.Range("M119")) + "\" + CStr(.Range("M118"))

'Crear la carpeta del día

'Te he creado un bucle para que se cree otro directorio, por si te equivocas

'ej, Si estamos a 25. La 1a vez te creara el directorio 25

' La 2a vez el 25(1), y la tercera el 25(2)

        carpeta_creada = ExisteCarpeta(nueva_ruta + "\" + CStr(.Range("J118")))
        If (carpeta_creada = False) Then
            Call CreaNuevaCarpeta(nueva_ruta, CStr(.Range("J118").Value))
        Else
            While (carpeta_nuevo_archivo = True)
            ' carpeta_nuevo_archivo = True
                carpeta_nuevo_archivo = ExisteCarpeta(nueva_ruta + "\" + CStr(.Range("J118")) + "(" + CStr(i) + ")")
                If (carpeta_nuevo_archivo = True) Then
                    i = i + 1
                Else
                    Call CreaNuevaCarpeta(nueva_ruta, CStr(.Range("J118")) + "(" + CStr(i) + ")")
                    carpeta_nuevo_archivo = False
                End If
            Wend
        End If
    End With
End Sub

Hola Antares, se ve que la hora no es la más indicada para hacer esto, menos mal que solo me queda una hora antes de salir..., aunque de todas las maneras, al ver tu macro, me ha dado un "pasmo", no entiendo nada.

Mañana por la noche intentaré ponerme con ella, aunque el primer intento de hoy ha sido de fiasco total.

Veo que tu también estás de "vela", bueno, gracias por todo, que descanses

Es fácil, lo que hace la sub ahora es

Mira si hay una carpeta llamada 2015, la carpeta del año

Si no la hay, la crea

Mira si hay una carpeta llamada 6, la carpeta del mes

Si no la hay la crea.

Mira si hay una carpeta llamada 25, el dia que corresponda

Si no la hay la crea. Pero además.

Si haces varias cosas un mismo día, lo que hace la sub es crearte carpetas tipo

25(1), 25(2). Así si te equivocas la información no se va a borrar, se pondrá en otra carpeta llamada 25(1)

Hola Antares, he probado por activa y por pasiva tu macro, no consigo que funciones, ya en el primer paso, donde pones "La función CrearNuevaCarpeta se queda igual", ya me he perdido, creo que todo el error viene de ahí.

Bueno, ya me dirás, y gracias

Borra la función que te dí de CrearNuevaCarpeta y pon esta. A ver si te funciona

Sub CreaNuevaCarpeta(ruta As String, NomCarpeta As String)
'Solo crea la carpeta

'Todo esto en 1 sola línea
    If Dir(ruta & "\" & NomCarpeta, vbDirectory + vbHidden) = "" Then MkDir ruta & "\" & NomCarpeta
End Sub

Hola Antares, lo primero disculparme por la tardanza, he estado bastante liado con el trabajo.

He intentado trabajar con la macro, siempre es mejor currárselo un poco para luego entenderlo todo, o casi todo.

Bueno, he conseguido crera la carpeta del año, las subcarpeta del mes, la subsubcarpeta del día, pero no consigo poner el archivo dentro de esta última.

Te paso lo que tengo hasta ahora

Sub IMPRIMIR()
Range("M7").Value = Now
'
Dim Nom_Carpeta As String
Nom_Carpeta = Range("M119").Value
If Nom_Carpeta = "" Then
Exit Sub
End If
Dim Nom_SubCarpeta As String
Nom_SubCarpeta = Range("M118").Value
If Nom_SubCarpeta = "" Then
Exit Sub
End If
Dim Nom_SubSubCarpeta As String
Nom_SubSubCarpeta = Range("J118").Value
If Nom_SubSubCarpeta = "" Then
Exit Sub
End If
On Local Error Resume Next
MkDir "C:\Users\es07813894n\Desktop\PRUEBAS\" & Nom_Carpeta
MkDir "C:\Users\es07813894n\Desktop\PRUEBAS\" & Nom_Carpeta & "\" & Nom_SubCarpeta
MkDir "C:\Users\es07813894n\Desktop\PRUEBAS\" & Nom_Carpeta & "\" & Nom_SubCarpeta & "\" & Nom_SubSubCarpeta
ActiveWorkbook.SaveAs Filename:=carpeta & Archivo, FileFormat:=xlNormal
Application.ScreenUpdating = False
Sheets("ENTREVISTA").Visible = True
Sheets("DOCUMENTO PARA LUCHA").Visible = True
Sheets("ENTREVISTA").PrintOut
Sheets("DOCUMENTO PARA LUCHA").PrintOut
Sheets("DOCUMENTO PARA LUCHA").Visible = False
Dim hj
Application.ScreenUpdating = False
For Each hj In Array("DOCUMENTO PARA ECONOMICO")
With Worksheets(hj)
If .['DOCUMENTO PARA ECONOMICO'!BE40] <> "" Then
.Visible = True: .PrintOut: .Visible = False
End If
End With
Next
End Sub

Gracias por todo

Solucionado, gracias

Has de finalizar la pregunta

¡Gracias! , espero que con esto finalice la pregunta, sino, hazme el favor de dedirme como hacerlo