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
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 SubEn 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
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