Copiar celdas de varios libros en una hoja de un nuevo libro
Hace algunos días me escribiste una macro para copiar filas que va de lujo. Tomando esa como modelo, he escrito esta otra para copiar las celdas C2 y C40 y el rango A36:N38 de todos los libros seleccionados en una hoja nueva desde donde ejecuto la macro con un botón.
Esta es la macro:
Sub CopiarFilas2()
'Por.Dante Amor
'Copiar Filas de Varios Libros Modificada
Application.ScreenUpdating = False
Set l1 = ThisWorkbook
Set h1 = l1.Sheets(1)
contador1 = 2
contador2 = 3
h1.UsedRange.Offset(1, 0).ClearContents
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Seleccion Archivos de excel. CTRL + Clic del ratón para seleccionar varios."
.Filters.Clear
.Filters.Add "Archivos de excel.", "*.xls*"
.AllowMultiSelect = True
.InitialFileName = ThisWorkbook.Path
If .Show Then
For Each arch In .SelectedItems
Set l2 = Workbooks.Open(arch)
For Each h2 In l2.Sheets
u1 = h1.Range("b" & Rows.Count).End(xlUp).Row + 1
u2 = h2.Range("b" & Rows.Count).End(xlUp).Row
h2.Range("c2").Copy
h1.Range("a" & contador1).PasteSpecial xlAll
h2.Range("c40").Copy
h1.Range("a" & contador2).PasteSpecial xlAll
h2.Range("a36:n38").Copy
h1.Range("b" & u1).PasteSpecial xlPasteAll
h1.Range("b" & u1).PasteSpecial xlPasteValues
contador1 = contador1 + 3
contador2 = contador2 + 3
Next
l2.Close
Next
End If
End With
Application.ScreenUpdating = True
MsgBox "Fin"
Range("A2").Select
End Sub
Me funciona, pero es muy lenta. ¿Podrías darle un vistazo y ver de optimizarla?.
1 Respuesta
Prueba así:
Sub CopiarFilas2()
'Por.Dante Amor
'Copiar Filas de Varios Libros Modificada
Application.ScreenUpdating = False
Set l1 = ThisWorkbook
Set h1 = l1.Sheets(1)
contador1 = 2
contador2 = 3
h1.UsedRange.Offset(1, 0).ClearContents
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Seleccion Archivos de excel. CTRL + Clic del ratón para seleccionar varios."
.Filters.Clear
.Filters.Add "Archivos de excel.", "*.xls*"
.AllowMultiSelect = True
.InitialFileName = ThisWorkbook.Path
If .Show Then
For Each arch In .SelectedItems
Set l2 = Workbooks.Open(arch)
For Each h2 In l2.Sheets
u1 = h1.Range("b" & Rows.Count).End(xlUp).Row + 1
'u2 = h2.Range("b" & Rows.Count).End(xlUp).Row
h2.Range("c2").Copy h1.Range("a" & contador1)
h2.Range("c40").Copy h1.Range("a" & contador2)
h2.Range("a36:n38").Copy h1.Range("b" & u1)
'h1.Range("b" & u1).PasteSpecial xlPasteValues
contador1 = contador1 + 3
contador2 = contador2 + 3
Next
l2.Close
Next
End If
End With
Application.ScreenUpdating = True
MsgBox "Fin"
Range("A2").Select
End Sub
Espero que ahora sea más rápida. R ecuerda valorar la respuesta.
Saludos Dante. Muchas gracias por tu interés. Se me olvidó mencionar que lo que hay en el rango a copiar ("a36:n38") son los valores resultantes de formulas que están en esas mismas celdas, p.e. Suma(c5:c36), por tanto me da error al copiarlos con esta linea : h2.Range("a36:n38").Copy h1.Range("b" & u1)
Lo he solucionado de esta manera:
h2.Range("a36:n38").Copy
h1.Range("b" & u1).PasteSpecial xlPasteAll
h1.Range("b" & u1).PasteSpecial xlPasteValues.
Pongo PasteAll para que me copie los formatos (todos los bordes, numeros con 2 decimales, centrado, y color de fondo) y luego PasteValues y me copia los datos exactamente como quiero, pero no se si es la mejor opción o si es esto lo que hace ralentizar la ejecución de la macro.
No obstante y de nuevo, muchísimas gracias.
Un saludo desde España
H o l a:
Al copiar los formatos y después los valores, es por eso que la macro se hace lenta, pero si es lo que necesitas, entonces no se puede optimizar más.
