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

1 respuesta

Respuesta
1

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.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas