Como hacer un MACRO para importar varios archivos TXT con cierta información y quede ordenado por fecha
Tengo varios archivos txt ordenados nombrados por fecha ejemplo LIST-010112z2017.txt ; LIST-020112z2017.txt ; LIST-030112z2017
Y solo quiero extraer cierta información como la que esta marcada en azul.
El cantidad de lineas en el texto es variable es decir, lo marcado en azul puede estar mas arriba o mas, pero solo me interesa extraer (donde esta marcado en azul) en donde dice Press Hpa hasta la ultima linea que dice 50.0 20634 //// /// ///// /// ////
Al final debe quedar asi:
Quedaría así, seria el nombre del archivo como fecha en esa misma fila, y todos los datos extraídos en una sola fila. Es decir cada archivo quede en una sola fila por fecha.
H o la: Te anexo la macro.
Supongo que el encabezado es el mismo, también que el número de columnas es el mismo, es decir, veo que son 7 columnas. También supongo que la separación de los datos está por tabulador.
Cambia en la macro "resultado", por el nombre de la hoja donde quieres el resultado de la importación.
También cambia "C:\Trabajo\temporal\", por el nombre de la carpeta donde tienes los datos.
La macro:
Sub ImportarTxt()
'Por.Dante Amor
Application.ScreenUpdating = False
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("resultado")
ruta = "C:\Trabajo\temporal\"
arch = Dir(ruta & "*.txt")
h1.Cells.Clear
j = 2
Do While arch <> ""
Workbooks.OpenText Filename:=ruta & arch, _
Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, _
TextQualifier:=xlNone, ConsecutiveDelimiter:=True, _
Tab:=True, Semicolon:=False, Comma:=False, Space:=True, _
Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1)), _
TrailingMinusNumbers:=True
Set l2 = ActiveWorkbook
Set h2 = l2.Sheets(1)
Set b = h2.Columns("A").Find("Press", lookat:=xlWhole)
If Not b Is Nothing Then
fec = Left(arch, Len(arch) - 4)
h1.Cells(j, "A") = fec
f = b.Row + 2
k = 2
Do While h2.Cells(f, "A") <> ""
h2.Range(h2.Cells(f, "A"), h2.Cells(f, "G")).Copy h1.Cells(j, k)
k = k + 7
f = f + 1
Loop
j = j + 1
End If
l2.Close False
arch = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "Importación de archivos terminada", vbInformation, "IMPORTAR ARCHIVOS TXT"
End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
Buenas tardes,
Cambien el nombre de la hoja y de la ruta como me lo sugirio para que corriera la macros pero algo paso que no corrió, dejo todo en blanco en la hoja, pero le dejo un ejemplo de los archivos a los que le quiere extraer y ordenar la información, gracias por su oportuna respuesta.
No puedo descargar archivos, envíame 3 archivos txt y un archivo de excel con la carga de esos 3 archivos txt.
Mi correo [email protected]
En el asunto del correo escribe tu nombre de usuario “Jesus Salazar” y el título de esta pregunta.
Te anexo la macro actualizada, lo que pasa es los datos empiezan en la columna B
Sub ImportarTxt()
'Por.Dante Amor
Application.ScreenUpdating = False
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("test")
ruta = "C:\Trabajo\temporal\"
arch = Dir(ruta & "*.txt")
u = h1.Range("A" & Rows.Count).End(xlUp).Row + 2
h1.Range(h1.Cells(3, "A"), h1.Cells(u, Columns.Count)).Clear
j = 3
Do While arch <> ""
Workbooks.OpenText Filename:=ruta & arch, _
Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, _
TextQualifier:=xlNone, ConsecutiveDelimiter:=True, _
Tab:=True, Semicolon:=False, Comma:=False, Space:=True, _
Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1)), _
TrailingMinusNumbers:=True
Set l2 = ActiveWorkbook
Set h2 = l2.Sheets(1)
Set b = h2.Columns("B").Find("Press", lookat:=xlWhole)
If Not b Is Nothing Then
fec = Left(arch, Len(arch) - 4)
h1.Cells(j, "A") = fec
f = b.Row + 2
k = 2
Do While h2.Cells(f, "B") <> ""
h2.Range(h2.Cells(f, "B"), h2.Cells(f, "H")).Copy h1.Cells(j, k)
k = k + 7
f = f + 1
Loop
j = j + 1
End If
l2.Close False
arch = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "Importación de archivos terminada", vbInformation, "IMPORTAR ARCHIVOS TXT"
End SubR ecuerda cambiar la valoración de la respuesta
¡Gracias!
Eres un Maestro-Pro!!!!
Al final de la respuesta hay un botón para cambiar la valoración de la respuesta de "Votar" a "Excelente", no olvides cambiarla.
