Copiar contenido de archivos de Texto a Excel.

Tengo una carpeta en una ruta especifica que contiene 100 subcarpetas y cada una a su vez, tiene 10 carpetas dentro de ellas, en las cuales viene un archivo de texto.txt del cual quiero extraer el contenido y pegarlo en una hoja de calculo de excel.

La macro que estoy generando hasta ahorita, tengo que seleccionar la ruta de cada una de las carpetas y esta un poco tedioso,¿Tendrán alguna opción que me pudiera ayudar a agilizar mi avance?

2 respuestas

Respuesta
3

Con esta macro abres todos los archivos txt de todas las carpetas que están contenidas en la carpeta específica.

Dim j
Dim rutas As New Collection
Sub carpetasysub()
'Por.Dante Amor
'lista archivos de una carpeta y todas las subcarpetas y todos sus archivos
    Sheets("Hoja2").Select
    pPath = "C:\"
    ext = "txt"
    'On Error Resume Next
    Set n = CreateObject("shell.application")
        carpeta = n.browseforfolder(0, _
                "Selecciona el Directorio Inical", 0, _
                pPath).items.Item.Path
    If carpeta = "" Then Exit Sub
    pPath = carpeta & "\"
    uf = Range("C" & Rows.Count).End(xlUp).Row
    If uf = 1 Then uf = 2
    Range("A2:C" & uf).Clear
    j = 2
    rutas.Add carpeta
    Call agregadir(pPath)
        j = 2
        For Each sd In rutas
            arch = Dir(sd & "\*." & ext)
            Range("B" & j) = sd
            Do While arch <> ""
                Range("C" & j) = arch
                Set l2 = Workbooks.Open(sd & "\" & arch)
                'En este parte tienes que poner qué vas a hacer
                'Copiar la hoja o copiar celdas
                'Y en dónde lo vas a pegar
                arch = Dir
                j = j + 1
            Loop
        Next
    Set rutas = Nothing
    Columns("A:C").EntireColumn.AutoFit
    MsgBox "Fin, buscar archivos", vbInformation, "Directorios"
End Sub
Sub agregadir(lpath)
'Agrega directorios
'Por.Dante Amor
    Dim SubDir As New Collection
    If Right(lpath, 1) <> "\" Then lpath = lpath & "\"
    DirFile = Dir(lpath & "*", vbDirectory)
    Do While DirFile <> ""
        'Agrega subdirectorios a collection
        If DirFile <> "." And DirFile <> ".." Then _
            If ((GetAttr(lpath & DirFile) And vbDirectory) = 16) Then _
                SubDir.Add lpath & DirFile
        DirFile = Dir
    Loop
    For Each sd In SubDir
        Range("A" & j) = sd
        j = j + 1
        rutas.Add sd
        Call agregadir(sd)
    Next
End Sub

En la macro puse estos comentarios

'En este parte tienes que poner qué vas a hacer
'Copiar la hoja o copiar celdas
'Y en dónde lo vas a pegar

Ahí tienes que poner lo que quieres hacer.

La macro te escribe en la "Hoja2" la carpeta, la subcarpeta y el archivo txt, en las columnas a, b y c.

Tienes dudas de lo que falta avísame, qué quieres copiar y en dónde lo quieres pegar.

Saludos. Dante Amor

Si es lo que necesitas recuerda valorar la respuesta.

Te anexo la macro corregida. En la Hoja1 te agrega la información y en la Hoja2 te pone los directorios y los archivos que fueron agregados.

Dim j
Dim rutas As New Collection
Sub carpetasysub()
'Por.Dante Amor
'lista archivos de una carpeta y todas las subcarpetas y todos sus archivos
    '
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets("Hoja1")
    Set h2 = l1.Sheets("Hoja2")
    '
    h1.Cells.Clear
    h2.Select
    h2.Cells.Clear
    h2.Range("A1:C1") = Array("DIRECTORIO", "SUBDIRECTORIO", "ARCHIVOS")
    pPath = "C:\"
    ext = "txt"
    '
    Set n = CreateObject("shell.application")
        carpeta = n.browseforfolder(0, _
                "Selecciona el Directorio Inical", 0, _
                pPath).items.Item.Path
    '
    If carpeta = "" Then Exit Sub
    '
    pPath = carpeta & "\"
    '
    h2.Range("A2") = pPath
    j = 2
    rutas.Add carpeta
    Call agregadir(pPath)
    '
    j = 2
    For Each sd In rutas
        arch = Dir(sd & "\*." & ext)
        h2.Range("B" & j) = sd
        Do While arch <> ""
            h2.Range("C" & j) = arch
            '
            Set l2 = Workbooks.Open(sd & "\" & arch)
            '
            Set h3 = l2.ActiveSheet
            u = h1.UsedRange.Rows(h1.UsedRange.Rows.Count).Row
            h3.UsedRange.Copy h1.Range("A" & u)
            l2.Close
            arch = Dir
            j = j + 1
        Loop
    Next
    '
    Set rutas = Nothing
    h2.Columns("A:C").EntireColumn.AutoFit
    h1.Select
    Application.ScreenUpdating = False
    MsgBox "Fin, copiar archivos txt", vbInformation, "ARCHIVOS"
End Sub
Sub agregadir(lpath)
'Agrega directorios
'Por.Dante Amor
    Dim SubDir As New Collection
    If Right(lpath, 1) <> "\" Then lpath = lpath & "\"
    DirFile = Dir(lpath & "*", vbDirectory)
    Do While DirFile <> ""
        'Agrega subdirectorios a collection
        If DirFile <> "." And DirFile <> ".." Then _
            If ((GetAttr(lpath & DirFile) And vbDirectory) = 16) Then _
                SubDir.Add lpath & DirFile
        DirFile = Dir
    Loop
    For Each sd In SubDir
        'Range("A" & j) = sd
        j = j + 1
        rutas.Add sd
        Call agregadir(sd)
    Next
End Sub
Respuesta
2

Prueba esta macro:

IMPORTANTE:

En la fila que empieza:    ruta = .......

Tienes que pegar el path del primer nivel de tus carpetas, es decir, la primera carpeta de todas.

Sub proceso()
'por luismondelo
Application.DisplayAlerts = False
mio = ActiveWorkbook.Name
ruta = "C:\Users\luismondelo\Documents\NIVEL1\" 'este es el primer nivel
Set fso = CreateObject("scripting.filesystemobject")
Set carpeta = fso.getfolder(ruta)
For Each subcarpeta In carpeta.subfolders
For Each subcarpeta2 In subcarpeta.subfolders
For Each fichero In subcarpeta2.Files
MsgBox fichero.Name
Workbooks.OpenText fichero, origin:=xlWindows, startrow:=1
otro = ActiveWorkbook.Name
Range("a1").CurrentRegion.Copy
Workbooks(mio).Activate
Range("a65000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Workbooks(otro).Close False
Next
Next
Next
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas