Buenos días, 

Necesito vuestra ayuda, estoy trabajando y me han pedido que haga una macro para unos archivos futuros, por ahora solo hay 3 archivos completos y el resto están vacíos y se irán completando a lo largo de los próximos meses. 

Necesito hacer una macro que copie los datos de varios archivos(en concreto 37) que se podría ampliar en un futuro en uno sólo. El archivo en el que estarán todos los datos está ubicado en el escritorio y los archivos con datos serán llamados 1,2,3...hasta el último que tendría de nombre de archivo 37.

Sub CopyDataFromMultipleWorkbooks()

Dim wbSource As Workbook
Dim wbDestination As Workbook

' Open the destination workbook where you want to copy the data
Set wbDestination = Workbooks.Open("C:\DestinationWorkbook.xlsx")

' Loop through all the source workbooks that you want to copy data from
For Each wbSource In Workbooks
    If wbSource.Name <> wbDestination.Name Then
        ' Copy the data from the source workbook to the destination workbook
        wbSource.Sheets("Sheet1").Range("A1:D10").Copy _
          Destination:=wbDestination.Sheets("Sheet1").Range("A1")
    End If
Next wbSource

End Sub
 

Este código es un ejemplo de cómo podría según un chat inteligente pero me gustaría saber si es cierto o cómo sería con los datos que he puesto arriba ya que el código que he puesto que me han dado es muy general. 

Inserto el archivo 1,2 y 3 que son los únicos que hay completos por si ayuda.

Muchas gracias y buen día a todos!

1.csv 2.csv 3.csv

Hi.

Crea un módulo y le pegas este dentro. Debería ser suficiente.

'En mFolder Tienes que identificar el nombre dentro de una sub carpeta \"****"
'En iFile pones el nombre con el que inician los archivos, todos deben iniciar igual
'En With ws pones al alto y ancho de la hoja a copiar celdas y filas
'iRow pones el alto con el número de filas
'En .Formula colocas el nombre de la hoja a traer los datos y la celda desde donde inicia
'------------------
Dim ws As Worksheet, iFile$, iRow&, mFolder$
Set ws = ActiveSheet
ws.Range(ws.[a1], ws.[a1].SpecialCells(11)).Offset(1).Delete xlShiftUp
mFolder = ThisWorkbook.Path & "\CARPETA"
iFile = Dir(mFolder & "\LIBRO*.xls*")
iRow = 6
Do Until iFile = ""
With ws.Cells(iRow, "A").Resize(10, 22)
.Formula = "=if('" & mFolder & "\[" & iFile & "]HOJA'!A1="""", """", '" & mFolder & "\[" & iFile & "]HOJA'!A1)"
.Value = .Value
End With
iFile = Dir
iRow = iRow + 10
Loop

 

Si amplias los rangos, solo editalo.

Saludines

Editado el el 15 de diciembre2 años por Israel Cassales