Macro para extraer datos de archivos excel

Utiliza la siguiente macro, pon la macro en un libro nuevo, guarda el libro en la misma carpeta en donde tienes todos los archivos. Ejecuta la macro y en la primer hoja tendrás los datos.

Revisa los resultados y me comentas si hay que cambiarle algo a la macro.

Sub copia_hojas()
'Por.DAM
    On Error Resume Next
    hoja = "pedido final"
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    '
    Set l1 = ThisWorkbook.Sheets("Hoja1")
    Set h1 = l1.Sheets(1)
    '
    ruta = ThisWorkbook.Path
    ChDir ruta
    archi = Dir("*.xls*")
    Do While archi <> ""
        If archi <> h1.Name Then
            Workbooks.Open archi
            If Err.Number = 0 Then
                uf = h1.Range("A1").SpecialCells(xlLastCell).Row + 1
                Sheets(hoja).Range("A2:G30").Copy h1.Cells(uf, "A")
                Workbooks(archi).Close
            End If
            Err.Number = 0
        End If
        archi = Dir()
    Loop
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Proceso de copiar hojas, Terminado", vbInformation
End Sub

hola

antes de nada muchas gracias por la ayuda

he probado la macro pero me abre los archivos por la hoja "pedido final" pero no me copia nada

lo que he hecho es crear un nuevo excel en la carpeta "semana 25", doy a alt f11, hago doble click en hoja1 y pego el texto en la parte derecha

cuando ejecuto la macro me abre todos los archivos por la hoja "pedido final" y no hace nada más

igual estoy haciendo algo mal, si puedes echarle un vistazo te lo agradezco

un saludo

Disculpa por el contratiempo.

Utiliza esta macro.

Sub copia_hojas()
'Por.DAM
    On Error Resume Next
    hoja = "pedido final"
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    '
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets(1)
    '
    ChDir ThisWorkbook.Path
    archi = Dir("*.xls*")
    '
    Do While archi <> "" And archi <> l1.Name
        Workbooks.Open archi
        uf = h1.UsedRange.Rows(h1.UsedRange.Rows.Count).Row + 1
        Sheets(hoja).Range("A2:G30").Copy h1.Cells(uf, "A")
        Workbooks(archi).Close
        archi = Dir()
    Loop
    '
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Proceso de copiar hojas, Terminado", vbInformation
End Sub

Igualmente revisa el resultado, si tienes algún problema avísame para revisarlo.

Saludos. Dante Amor

muchas gracias

he probado y ya saca un listado en una hoja excel

sin embargo no coge las 30 filas de cada una de los archivos, sino que coge todo del mismo archivo, el primero

a ver si puedes echarme una mano

un saludo

Cambia en la macro esta línea

uf = h1.UsedRange.Rows(h1.UsedRange.Rows.Count).Row + 1

Por esta

uf = h1. Range("A1"). SpecialCells(xlLastCell). Row + 1

Revisa el resultado en toda la hoja, ya que con esta instrucción también te respetará las filas que tienes en blanco, es decir, si tienes 29 líneas en blanco, en al copia te pondrá 29 líneas en blanco.

También revisa que tus archivos tengan la hoja "pedido final", si no tienes una hoja con ese nombre en los archivos no te va a copiar nada.

hola

he hecho el cambio y hace la función correctamente para las columnas A y B. A partir de la C es cuando falla

he chequeado que los archivos de origen estén correctos y está todo ok

la verdad que no sé por qué puede ser este error

un saludo y muchas gracias!