Macro excel para copiar registros de varios libros

Desde España.

Llevo varios días tratando de adaptar alguna de tus macros para que haga lo que yo quiero, pero no lo consigo. No tengo mucha experiencia en vba.

Tengo en Excel un libro nuevo con una sola hoja con un encabezado (a1:g1). Desde este libro pretendo lo siguiente:

Mediante Aplication. GetOpenFilename..., seleccionar todos los libros de los que quiero la información. Dichos libros pueden tener varias hojas.

De cada una de las hojas de los libros seleccionados, quiero que me copie todos los registros que hay empezando en A11 y terminando en G(n) de la última fila con datos. Si A11="", que salte a la siguiente hoja. Este proceso se repetirá hasta el último libro.

Estos registros se copiarán por filas (sin filas en blanco) uno debajo de otro en la hoja donde estoy ejecutando la macro a partir de A2.

Básicamente se trata de reunir todos los registros de todos los libros para luego hacer búsquedas.

1 Respuesta

Respuesta
1

H o  la:

Te anexo la macro

Sub CopiarFilasVariosLibros()
'Por.Dante Amor
    'Copiar Filas de Varios Libros
    Application.ScreenUpdating = False
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets(1)
    h1.UsedRange.Offset(1, 0).ClearContents
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Seleccion Archivos de excel"
        .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("A" & Rows.Count).End(xlUp).Row + 1
                    u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
                    If u2 > 10 Then
                        h2.Range("A11:G" & u2).Copy
                        h1.Range("A" & u1).PasteSpecial xlValues
                    End If
                Next
                l2.Close
            Next
        End If
    End With
    Application.ScreenUpdating = True
    MsgBox "Fin"
End Sub


' : )
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
' : )

¡Gracias!

... Por compartir conocimientos, por la prontísima respuesta, por tu inteligencia al descifrar a la primera lo que yo quería, por ... en definitiva, por ser como eres.

Además de todo esto, la rutina funciona de lujo.

Un abrazo desde España.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas