Macro para hoja resumen de varios libros

[Ner]

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

[Héctor Miguel]

la macro que expones presenta varias inconsistencias (o errores) de acuerdo con "la intención" que mencionas (p.ej.)

con esta línea:

Set SummarySheet = ThisWorkbook.Worksheets[/CODE]

asignas una clase de objeto que se refiera a la colección (todas) de las hojas en el libro que contiene la macro (pero a ninguna en especifico)

con estas otras líneas:

[CODE]' 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[/CODE]

- primero localizas la ultima fila con datos de la columna A

- luego estableces otra variable de objeto (rango) desde A9:L[ultima fila]

- luego seleccionas ese rango

- después, EXTIENDES esa selección hacia la derecha y hacia abajo

(si no hay datos después de esa primera selección, al final de cuentas (re)seleccionas TODAS las celdas)

- entonces, lo que estas ".Copy"(ando) es... ???

mira ejemplos en la sección "Workbook Examples" de esta pagina:

http://www.rondebruin.nl/win/section3.htm

saludos,

hector.

[Ner]

Buenos días Hector,

Ante todo gracias por responder. He corregido un par de cosas porque al final, no soy una experta de excel a nivel macros ni mucho menos pero tengo que hacer esto y entre lo poco que sabes y cosas que encuentras más o menos he conseguido algo, pero no tengo nociones como para dominar lo que estoy haciendo y soy consciente que hago cosas mal. Lo que quería que hiciera en las celdas que comentas es que me copie de un archivo desde A9 (las columnas A-L) y hasta la última fila que tenga datos... y eso lo ponga en el archivo resumen (inspecciones).

Ahora he conseguido que copie algo en el archivo destino (inspecciones) pero cuando en la carpeta hay más de un archivo que fusionar y del que obtener la informacion de sus respectivas celdas A9-L9 hasta el final de cada uno de los archivos, lo que está haciendo es pegarlo encima y no a continuación...

¿Alguna idea? Y ya digo que muchas gracias a todo aquel que pueda ayudarme porque todo lo que me digan será bueno para aprender. Saludos

Sub copiar_libros()

Dim NRow As Long

Dim LastRow As Integer

Dim ruta As String

Dim archi As String

Dim SourceRange As Range

Dim DestRange As Range

Dim SummarySheet As Excel.Worksheet 'libro que contiene el archivo destino (info de inspecciones)

Dim wsOrigen As Excel.Worksheet

Dim WorkBk As Workbook

Dim wbOrigen As Workbook

Application.ScreenUpdating = False

ruta = ThisWorkbook.Path 'ruta de la carpeta contenedora de archivos

archi = Dir(ruta & "\*.xls*") 'llamar a Dir para señalar a todos los archivos dentro del path

NRow = 9 'indicador de FILAS del archivo destino

Set SummarySheet = ThisWorkbook.Worksheets("hoja1") 'Selecciona hoja1 del archivo donde se ejecuta la macro (inspecciones)

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

' Copy over the values from the source to the destination.

'DestRange.Value = SourceRange.Value

' 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