Creación masiva de carpetas en excel

Tengo el código (al final) que debería ejecutar la siguiente secuencia.

1- Leer primera línea de la hoja de calculo

2- Verificar si existe carpeta

  • Si no existe
    • crear carpeta
    • Crear TXT
    • Añadir líneas al txt
  • >Si existe
    • Verificar si existe txt
      • Si no existe
        • Crear TXT
        • Añadir líneas al txt
      • Si existe
        • Añadir líneas al txt

3- Leer siguiente línea de la hoja de calculo e ir a 2, si es la ultima, seguir en 4

4- Mostrar mensaje de "Exportación finalizada"

_

Esto lo he representado con el siguiente código,¿Puede alguien revisarlo e indicarme donde esta el error?.

Private Sub CreacionMasivaCarpetas()
Set h0 = Sheets("Datos")
Set h1 = Sheets("DateUser")
i = h0.Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To i
Ruta = "G:\IMMOBLES_B\EXPEDIENTS_0\" & h0.Cells(i, "G") & "\" & h0.Cells(i, "H")
docu = "Anotacions.txt"
x = Dir(Ruta, vbDirectory)
    If x = "" Then
            Dim obj  As Object
            Dim car  As Variant
            Set obj = CreateObject("WScript.Shell")
            car = Ruta
            Set obj = Nothing
            Set obj = CreateObject("Scripting.FileSystemObject")
            If obj.FolderExists(car) = False Then obj.CreateFolder (car)
            Set obj = Nothing
            Set fs = CreateObject("Scripting.FileSystemObject")
            Set a = fs.CreateTextFile(Ruta & "\" & docu, True)
            a.WriteLine h1.Cells(1, "A").Value & " - " & h1.Cells(2, "A").Value
            a.WriteLine "Es crea l'arxiu d'anotacions."
            a.Close
            Open Ruta & "/" & docu For Append As #1
            Print #1,
            Print #1, h0.Cells(i, "B").Value & " - " & h0.Cells(i, "C").Value
            Print #1, h0.Cells(i, "D").Value & " - " & h0.Cells(i, "E").Value
            Print #1, h0.Cells(i, "F").Value
            Close #1
    Else
            Dim MyFile As String
            MyFile = Dir(Ruta & "\" & docu)
                If MyFile <> "" Then
                    Set fs = CreateObject("Scripting.FileSystemObject")
                    Set a = fs.CreateTextFile(Ruta & "\" & docu, True)
                    a.WriteLine h1.Cells(1, "A").Value & " - " & h1.Cells(2, "A").Value
                    a.WriteLine "Es crea l'arxiu d'anotacions."
                    a.Close
                    Open Ruta & "/" & docu For Append As #1
                    Print #1,
                    Print #1, h0.Cells(i, "B").Value & " - " & h0.Cells(i, "C").Value
                    Print #1, h0.Cells(i, "D").Value & " - " & h0.Cells(i, "E").Value
                    Print #1, h0.Cells(i, "F").Value
                    Close #1
                Else
                    Open Ruta & "/" & docu For Append As #1
                    Print #1,
                    Print #1, h0.Cells(i, "B").Value & " - " & h0.Cells(i, "C").Value
                    Print #1, h0.Cells(i, "D").Value & " - " & h0.Cells(i, "E").Value
                    Print #1, h0.Cells(i, "F").Value
                    Close #1
                End If
        End If
    Next i
MsgBox ("Exportacion finalizada")
End Sub

1 Respuesta

Respuesta
1

En esta línea te falta el objeto hoja

i = h0.Range("A" & .Rows.Count).End(xlUp).Row

Debe ser así:

i = h0.Range("A" & h0.Rows.Count).End(xlUp).Row

Todo lo demás funciona bien

Saludos. Dante Amor

No olvides valorar la respuesta.

¡Gracias!

Ahora ya me avanza de línea... pero se detiene en

obj.CreateFolder (car)

con Error: No se ha encontrado ruta de acceso

¿Puede ser que no tenga bien especificado " i "?

Este código lo tengo como Sub en otro libro para crear una carpeta mediante un botón y funciona bien. El único cambio es que aquí le hago ir avanzando de fila mediante " i " y parece ser que no lo detecta. ¿Puede ser?

Perdón, me emocioné de que alguien me contestara tan rápido!

He revisado varias veces el código, y he descubierto más faltas (barras mal puestas y me faltaba por declarar la variable i como integrer) También el error anterior se debía a que el directorio general no existía, por lo que no me creaba el subdirectorio (yo pensaba que si) así que he creado una sub anterior para que genere el subdirectorio si no existe.

El código ha quedado así:

Sub CreacionMasivaCarpetas()
Dim i As Integer
Set h0 = Sheets("Datos")
Set h1 = Sheets("DateUser")
For i = 1 To h0.Range("A" & h0.Rows.Count).End(xlUp).Row
'VERIFICAR SI EXISTE CARPETA
Ruta = "G:\IMMOBLES_B\EXPEDIENTS_0\" & h0.Cells(i, "G") & "\" & h0.Cells(i, "H")
Docu = "Anotacions.txt"
x = Dir(Ruta, vbDirectory)
    If x = "" Then
            'SI NO EXISTE CARPETA
            'CREAR CARPETA
            Dim obj  As Object
            Dim car  As Variant
            'Ruta = "G:\IMMOBLES_B\EXPEDIENTS_0\" & h0.Cells(i, "G") & "\" & h0.Cells(i, "H")
            Set obj = CreateObject("WScript.Shell")
            car = Ruta
            Set obj = Nothing
            Set obj = CreateObject("Scripting.FileSystemObject")
            If obj.FolderExists(car) = False Then obj.CreateFolder (car)
            Set obj = Nothing
            'CREAR ARCHIVO
            Set fs = CreateObject("Scripting.FileSystemObject")
            Set a = fs.CreateTextFile(Ruta & "\" & Docu, True)
            a.WriteLine h1.Cells(1, "A").Value & " - " & h1.Cells(2, "A").Value
            a.WriteLine "Es crea l'arxiu d'anotacions."
            a.Close
            'ESCRIBIR ARCHIVO
            Open Ruta & "\" & Docu For Append As #1
            Print #1,
            Print #1, h0.Cells(i, "B").Value & " - " & h0.Cells(i, "C").Value
            Print #1, h0.Cells(i, "D").Value & " - " & h0.Cells(i, "E").Value
            Print #1, h0.Cells(i, "F").Value
            Close #1
    Else
            'SI EXISTE CARPETA
            'VERIFICAR SI EXISTE ARCHIVO
            Dim MyFile As String
            MyFile = Dir(Ruta & "\" & Docu)
                'SI NO EXISTE ARCHIVO
                If MyFile <> "" Then
                   'CREAR ARCHIVO
                    Set fs = CreateObject("Scripting.FileSystemObject")
                    Set a = fs.CreateTextFile(Ruta & "\" & Docu, True)
                    a.WriteLine h1.Cells(1, "A").Value & " - " & h1.Cells(2, "A").Value
                    a.WriteLine "Es crea l'arxiu d'anotacions."
                    a.Close
                    'ESCRIBIR ARCHIVO
                    Open Ruta & "\" & Docu For Append As #1
                    Print #1,
                    Print #1, h0.Cells(i, "B").Value & " - " & h0.Cells(i, "C").Value
                    Print #1, h0.Cells(i, "D").Value & " - " & h0.Cells(i, "E").Value
                    Print #1, h0.Cells(i, "F").Value
                    Close #1
                Else
                    'ARCHIVO EXISTE
                    'ESCRIBIR ARCHIVO
                    Open Ruta & "\" & Docu For Append As #2
                    Print #2,
                    Print #2, h0.Cells(i, "B").Value & " - " & h0.Cells(i, "C").Value
                    Print #2, h0.Cells(i, "D").Value & " - " & h0.Cells(i, "E").Value
                    Print #2, h0.Cells(i, "F").Value
                    Close #2
                End If
        End If
    'PASAR A LA SIGUIENTE LINEA
    Application.Wait (Now + TimeValue("00:00:05"))
    Next i
MsgBox ("Exportacion finalizada")
End Sub

He tenido que añadir la linea de application.wait para dar tiempo a generar los archivos, aun asi me da errores en la ultima parte de 'ESCRIBIR ARCHIVO y se queda atorado ahi... empiezo a pensar que lo mejor es separarlo todo en varios modulos y ejecutarlos individualmente mediante botones

Te anexo la macro con todas las condiciones funcionando. En VBA excel, no es necesario que declares las variables, todas son declaradas como variant, sólo en algunos casos es necesario declararlas, pero mientras no te preocupes por declararlas VBA lo hace por ti.

Sub CreacionMasivaCarpetas()
'Por.Dante Amor
    Set h0 = Sheets("Datos")
    Set h1 = Sheets("DateUser")
    Docu = "Anotacions.txt"
    For i = 1 To h0.Range("A" & Rows.Count).End(xlUp).Row
        ruta = "G:\IMMOBLES_B\EXPEDIENTS_0\" & h0.Cells(i, "G") & "\" & h0.Cells(i, "H")
        If Dir(ruta, vbDirectory) = "" Then
            'SI NO EXISTE CARPETA CREAR CARPETA
            MkDir ruta
            CrearArchivo ruta, Docu, h1
            EscribeArchivo ruta, Docu, h0, i
        Else
            If Dir(ruta & "\" & Docu) = "" Then
                'SI NO EXISTE ARCHIVO 'CREAR ARCHIVO
                CrearArchivo ruta, Docu, h1
                EscribeArchivo ruta, Docu, h0, i
            Else
                EscribeArchivo ruta, Docu, h0, i
            End If
        End If
    Next
    MsgBox "Exportacion finalizada", vbInformation
End Sub
Sub EscribeArchivo(ruta, Docu, h0, i)
'Por.Dante Amor
    Open ruta & "\" & Docu For Append As #1
    Print #1,
    Print #1, h0.Cells(i, "B").Value & " - " & h0.Cells(i, "C").Value
    Print #1, h0.Cells(i, "D").Value & " - " & h0.Cells(i, "E").Value
    Print #1, h0.Cells(i, "F").Value
    Close #1
End Sub
Sub CrearArchivo(ruta, Docu, h1)
'Por.Dante Amor
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set a = fs.CreateTextFile(ruta & "\" & Docu, True)
    a. WriteLine h1.Cells(1, "A").Value & " - " & h1.Cells(2, "A").Value
    a. WriteLine "Es crea l'arxiu d'anotacions."
    a.Close
End Sub

Simplifiqué el código para crear carpeta

MkDir ruta

Y también simplifiqué el código para crear el archivo y para escribir en el archivo.

Ya probé todas las posibilidades y todas funcionan.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas

Sacar subotales por año arriba en la hoja

Ayudarme a que arriba aparezcan los totales por año de cada inquilino que vayamos a consultar Gracias Sub Buscar() 'Mod.Por.DAM Application.ScreenUpdating = False Set h1 = Sheets("Estados de cuenta") Set h2 = Sheets("Cartera.") '...
1 respuesta

Exportar mediante macro a txt

Quisiera saber como puedo hacer una macro que exporte varias tablas de una base a archivos txt separados por coma, el problema es que algunas tablas tienen campos con decimales y al hacerlo en forma manual, hay que ir a la configuración regional de...
1 respuesta

Exprtar a Excel

Viejo que pena que abuse de su confianza, lo que sucede es que estoy apenas aprendiendo visual... Tengo en un formulario un botón "llamado exportar" y dos textbox (fec_ini y fec_fin), deseo que dependiendo a ese rango de fecha me lleve a excel los...
1 respuesta

Como listar las distintas subcarpetas que hay dentro de una determinada carpeta.

Actualmente tengo una macro de Excel para listar los ficheros de una carpeta, pero querría listar también las subcarpetas que estén dentro de una determinada carpeta. ¿Es posible?
1 respuesta

Macro para disparar correos automáticos desde una BD

Trabajando en el mismo proyecto ahora tengo dos solicitudes del mismo tema, para mi seria mejor me ayuden resolviéndola por el camino 2: 1. Estoy intentando crear una rutina que me permita enviar correo automático en el momento en que falten 10 días...
1 respuesta

Implementar Progress Bar en macro para generar efecto visual

Sub Buscar() 'Mod.Por.DAM Application.ScreenUpdating = False Set h1 = Sheets("Estados de cuenta") Set h2 = Sheets("Cartera.") ' h1.Range("A18:E6000").ClearContents j = 18 Set r = h2.Columns("G") Set b = r.Find(h1.Range("A6"), LookIn:=xlValues,...
1 respuesta

Macro que un libro de llamado inventario de uno llamado srvicios diario

Tengo un inventario de 470 vehículos quiero poder realizar una macro que me optimice el tiempo, la cual me realice un barrido por el archivo servicios del mes y me actualice lo que se haya cambiado o modificado, se deben actualizar 4 celdas que hay...
1 respuesta

Copiar rango a otra hoja si una celda es mayor a 0

Busco una macro en excel que me ayude con lo siguiente: Tengo en el rango B9:N38 de la hoja 1 una tabla de datos. En la columna B de tal tabla hay valores que van a partir de 0. Deseo copiar de la hoja 1 a la hoja 2 aquellos "renglones" que en la...
1 respuesta

Macro para comparar datos de 2 libros de excel

Tengo una base la cual se alimenta con varios Excel... Llamemos les id (el num puede ser variable) yo tengo que comparar una columna de la base con una del id"el num es variable" y el dato de la casilla "a1" del id colocarlo en la columna "ah" de la...
1 respuesta

Dividir word en varios documentos

Tengo la necesidad de dividir un word en varios archivos independientes. Recibo cada día un archivo que contiene de 25 a 125 documentos en su interior. Entre ellos están separados por la leyenda *[SALTO_PAGINA]* De momento lo hacemos a mano, y nos...
1 respuesta