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