Macro para copiar datos de varios libros de unas celdas especificas y pegarlos en un libro nuevo en la primera hoja.
Mi pregunta es si hay alguna manera de copiar la información de un rango de la hoja1 de varios libros de unas celdas especificas ejem "a2:o2" y pegarla en un libro nuevo pero en la primera hoja, teniendo en cuenta que la hoja nueva tiene títulos.
Ya intente con una macro tomada de este mismo sitio y funciono pero me traia todos los rangos, luego la modifique como lo decía el experto para solo estos rangos pero no me trajo nada, no me dio resultado...
Gracias por su colaboración
Sub libros()
'Lee archivos del directorio y Copia la hoja 1
'Por.Dam
Application.ScreenUpdating = False
ruta = ThisWorkbook.Path
ChDir ruta
archi = Dir("*.xls*")
Set h1 = ThisWorkbook.Sheets("hoja2")
On Error Resume Next
Do While archi <> ""
If InStr(1, archi, "nuevo") = 0 Then
Workbooks.Open archi
If Err.Number = 0 Then
Sheets(2).Select
Range(Range("A2:O2")).Copy _
H1.Range("G" & h1. Range("A2:O2"). SpecialCells(xlLastCell).Row + 1)
Else
Err.Number = 0
End If
Application.DisplayAlerts = False
Workbooks(archi).Close
Application.DisplayAlerts = True
End If
archi = Dir()
Loop
End Sub
1 Respuesta
Respuesta de Dante Amor
2
Te anexo la macro actualizada, lee todos los archivos de la carpeta donde tienes el archivo con la macro, copia el rango de A2 a O2 y lo pega en la "Hoja2" del mismo libro que contiene la macro.
Sub libros()
'Lee archivos del directorio y Copia un rango de la primera hoja
'Por.Dante Amor
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set l1 = ThisWorkbook
ruta = ThisWorkbook.Path & "\"
archi = Dir(ruta & "*.xls*")
Set h1 = l1.Sheets("hoja2")
j = 2
Do While archi <> ""
If archi <> l1.Name Then
Set l2 = Workbooks.Open(ruta & archi)
Set h2 = l2.Sheets(1)
h2.Range("A2:O2").Copy h1.Range("A" & j)
j = j + 1
l2.Close
End If
archi = Dir()
Loop
MsgBox "Fin"
End Sub.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
