Copiar varios archivos en una sola hoja de otro libro
HOla, espero me puedas ayudar.
Tengo varios archivos (casi 200) de excel dentro de una carpeta, todos los archivos mantienen el mismo formato y solamente una hoja, lo que necesito es copiar el rango D3:X43 de cada libro en una sola hoja de un archivo nuevo, por ejemplo copiar D3:x43 del archivo1 y pegarlo en en A1:U42 del archivo nuevo, luego copiar D3:x43 de archivo2 y pegarlo debajo, es decir A44:U85 y así sucesivamente. También hay otro problema todos los archivos se generan mensualmente por lo que la ruta cambia, ¿seria posible que también preguntara la ruta donde están los archivos?
Gracias.
Tengo varios archivos (casi 200) de excel dentro de una carpeta, todos los archivos mantienen el mismo formato y solamente una hoja, lo que necesito es copiar el rango D3:X43 de cada libro en una sola hoja de un archivo nuevo, por ejemplo copiar D3:x43 del archivo1 y pegarlo en en A1:U42 del archivo nuevo, luego copiar D3:x43 de archivo2 y pegarlo debajo, es decir A44:U85 y así sucesivamente. También hay otro problema todos los archivos se generan mensualmente por lo que la ruta cambia, ¿seria posible que también preguntara la ruta donde están los archivos?
Gracias.
1 Respuesta
Respuesta de Juan Carlos González Chavarría
1
Prueba con esta macro para ver si te sirve
Sub ProcesaLote()
Dim FS As FileSearch
Dim FilePath As String, FileSpec As String
Dim i As Integer
FilePath = ThisWorkbook.Path & "\"
Set FS = Application.FileSearch
With FS
.LookIn = FilePath
.FileName = FileSpec
.Execute
' Salir si no se encontraron archivos
If .FoundFiles.Count = 0 Then
MsgBox "No se encontraron archivos"
Exit Sub
End If
End With
' Recorrer los archivos
For i = 1 To FS.FoundFiles.Count
Call ProcessFiles(FS.FoundFiles(i))
Next i
End Sub
Sub ProcesaArchivos(NombreArchivo As String)
Dim NextRow As Long
' Importar Archivos
Workbooks.Open FileName:=NombreArchivo, _
Origin:=xlWindows, _
StartRow:=1, _
DataType:=xlFixedWidth, _
FieldInfo:= _
Array(Array(0, 1), Array(3, 1), Array(12, 1))
' Rango para ser copiado
Range("D43:X43").Select
Selection.Copy
Windows("Tu Archivo.xls").Activate
NextRow = Range("A65536").End(xlUp).Row + 1
ActiveSheet.Paste
End Sub
Sub ProcesaLote()
Dim FS As FileSearch
Dim FilePath As String, FileSpec As String
Dim i As Integer
FilePath = ThisWorkbook.Path & "\"
Set FS = Application.FileSearch
With FS
.LookIn = FilePath
.FileName = FileSpec
.Execute
' Salir si no se encontraron archivos
If .FoundFiles.Count = 0 Then
MsgBox "No se encontraron archivos"
Exit Sub
End If
End With
' Recorrer los archivos
For i = 1 To FS.FoundFiles.Count
Call ProcessFiles(FS.FoundFiles(i))
Next i
End Sub
Sub ProcesaArchivos(NombreArchivo As String)
Dim NextRow As Long
' Importar Archivos
Workbooks.Open FileName:=NombreArchivo, _
Origin:=xlWindows, _
StartRow:=1, _
DataType:=xlFixedWidth, _
FieldInfo:= _
Array(Array(0, 1), Array(3, 1), Array(12, 1))
' Rango para ser copiado
Range("D43:X43").Select
Selection.Copy
Windows("Tu Archivo.xls").Activate
NextRow = Range("A65536").End(xlUp).Row + 1
ActiveSheet.Paste
End Sub
