He estado investigando y probando y no hay forma de conseguir lo que quiero. Dentro de una carpeta X voy a tener un conjunto de archivos: todos tienen el mismo formato, desde la fila 9 y columnas A-L, se tendrá la información que quiero pasar a otro archivo resumen "201509_inspecciones.xlsm" que tendrá un encabezado y demás por encima de la fila A9 y luego a partir de dicha celda quiero pegar el contenido de los archivos.
Bueno he intentado muchas cosas y esta es mi última versión. Si alguien me puede ayudar se lo agradecería.
Saludos
Sub copiar_libros()
Dim NRow As Long
Dim ruta As String
Dim LastRow As Integer
Dim WorkBk As Workbook
Dim archi As String
Dim SourceRange As Range
Dim DestRange As Range
Dim SummarySheet As Excel.Worksheet
Dim wsOrigen As Excel.Worksheet
Dim wbOrigen As Workbook
Application.ScreenUpdating = False
ruta = ThisWorkbook.Path
' Call Dir the first time, pointing it to all Excel files in the folder path.
archi = Dir(ruta & "\*.xls*")
' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 9
'Selecciona hoja1 del archivo donde se ejecuta la macro (inspecciones)
'ThisWorkbook.Activate
Set SummarySheet = ThisWorkbook.Worksheets
On Error Resume Next
' Loop until Dir returns an empty string.
Do While archi <> ""
If InStr(1, archi, "201509_inspecciones") = 0 Then
Set wbOrigen = Workbooks.Open(ruta & "\" & archi)
Set wsOrigen = wbOrigen.Worksheets(Hoja1)
If Err.Number = 0 Then
' Seleccionar el Source range a la última fila con datos
LastRow = Range("A65536").End(xlUp).Row
Set SourceRange = wsOrigen.Range("A9:L" & LastRow)
SourceRange.Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
' Set the destination range to start at column B and be the same size as the source range.
'inicializar el destino
Set DestRange = SummarySheet.Range("A" & NRow)
DestRange.PasteSpecial xlPasteValues
Application.CutCopyMode = False
' Increase NRow so that we know where to copy data next.
NRow = NRow + DestRange.Rows.Count
Else
Err.Number = 0
End If
Application.DisplayAlerts = False
Workbooks(archi).Close
Application.DisplayAlerts = True
End If
archi = Dir()
Loop
End Sub
Featured Replies
Archivado
Este tema está ahora archivado y está cerrado a más respuestas.
Buenos días,
He estado investigando y probando y no hay forma de conseguir lo que quiero. Dentro de una carpeta X voy a tener un conjunto de archivos: todos tienen el mismo formato, desde la fila 9 y columnas A-L, se tendrá la información que quiero pasar a otro archivo resumen "201509_inspecciones.xlsm" que tendrá un encabezado y demás por encima de la fila A9 y luego a partir de dicha celda quiero pegar el contenido de los archivos.
Bueno he intentado muchas cosas y esta es mi última versión. Si alguien me puede ayudar se lo agradecería.
Saludos
Sub copiar_libros()
Dim NRow As Long
Dim ruta As String
Dim LastRow As Integer
Dim WorkBk As Workbook
Dim archi As String
Dim SourceRange As Range
Dim DestRange As Range
Dim SummarySheet As Excel.Worksheet
Dim wsOrigen As Excel.Worksheet
Dim wbOrigen As Workbook
Application.ScreenUpdating = False
ruta = ThisWorkbook.Path
' Call Dir the first time, pointing it to all Excel files in the folder path.
archi = Dir(ruta & "\*.xls*")
' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 9
'Selecciona hoja1 del archivo donde se ejecuta la macro (inspecciones)
'ThisWorkbook.Activate
Set SummarySheet = ThisWorkbook.Worksheets
On Error Resume Next
' Loop until Dir returns an empty string.
Do While archi <> ""
If InStr(1, archi, "201509_inspecciones") = 0 Then
Set wbOrigen = Workbooks.Open(ruta & "\" & archi)
Set wsOrigen = wbOrigen.Worksheets(Hoja1)
If Err.Number = 0 Then
' Seleccionar el Source range a la última fila con datos
LastRow = Range("A65536").End(xlUp).Row
Set SourceRange = wsOrigen.Range("A9:L" & LastRow)
SourceRange.Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
' Set the destination range to start at column B and be the same size as the source range.
'inicializar el destino
Set DestRange = SummarySheet.Range("A" & NRow)
DestRange.PasteSpecial xlPasteValues
Application.CutCopyMode = False
' Increase NRow so that we know where to copy data next.
NRow = NRow + DestRange.Rows.Count
Else
Err.Number = 0
End If
Application.DisplayAlerts = False
Workbooks(archi).Close
Application.DisplayAlerts = True
End If
archi = Dir()
Loop
End Sub