Macro para juntar la información de 4 archivos de excel en una nueva hoja y de 1 archivo aparte en otra
Tengo un macro que juntas hojas pero no cumple con lo que necesito.
Me gustaría un macro que me permitiera seleccionar 4 archivos (cambian cada vez) y junte los datos de las primeras hojas de estos archivos en la primera hoja del libro donde estoy corriendo esta macro (el nombre de esta hoja es Concentrado); solo debe mantener el encabezado de la primera hoja que copie y en las otras 3 debe eliminarlo. El macro también debe pedirme un 5 archivo, cuya primera hoja copiará en la segunda hoja del libro donde estoy corriendo la macro (el nombre de esta hoja será Check).
El número de datos es variable en cada hoja y tienen que ser copiados todos aunque esten repetidos. Los archivos se encontrarán en la misma carpeta, tanto el que tiene el macro como los 5 archivos de los que se extraerá la información.
1 Respuesta
¿De los 4 archivos en qué fila está el encabezado?
¿Y a partir de cuál fila se empiezan los datos a copiar?
¿En cuál fila de la hoja "Concentrado" quieres el encabezado?
Quieres que se abra la ventana del explorador y seleccionar 4 archivos. ¿Luego quieres que se abra nuevamente la ventana del explorador y seleccionar el quinto archivo?
Hola:
En todos los archivos el encabezado está en la fila 1 y los datos a copiar inician a partir de la fila 2. El encabezado en la hoja "Concentrado" debería estar en la fila 1.
En cuanto a la ventana del explorador pensé que eran lo mejor que se abriera 2 veces, pero si crees que es mejor otra opción está bien.
Estaba haciendo un código como sigue, que te pide el nombre de las hojas (que siempre vienen en el formato dd-mm-aa) pero no funcionó.
'Application.ScreenUpdating = False
Hoja1 = InputBox("Introduce el nombre de la primera hoja (dd-mm-aa):")
If Hoja1 = "" Then Exit Sub
Workbooks.Open Filename:="D:\COMPRAS\" & Hoja1 & ".xls"
Windows(Hoja1 & ".xls").Activate
Sheets("Detalle H.E. pendientes").Select
Sheets("Detalle H.E. pendientes").copy Before:=Workbooks("Cálculo Avance Objetivo.xls"). _
Sheets(1)
Saludos y gracias
Te anexo la macro:
Primero te abre un ventana de explorador, para que selecciones los 4 archivos, puedes seleccionar los 4 presionando la tecla Ctrl y dando click al archivo con el mouse, repite los mismo para que selecciones los 4. Presiona Aceptar, la macro copiará la información a la primera hoja de tu libro.
Cuando la macro termina te abre otra ventana de explorador para que selecciones el 5o Archivo, presiona aceptar y la hoja se copiará en la segunda hoja de tu libro.
Sub CopiarVariosArchivos()
'Por.Dante Amor
'
Dim VariosArchivos As New Collection
'
Application.ScreenUpdating = False
Set l1 = ThisWorkbook
Set h1 = l1.Sheets(1)
Set h2 = l1.Sheets(2)
h1.Cells.Clear
ruta = l1.Path
'
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Seleccione archivos de excel"
.Filters.Clear
.Filters.Add "Todos", "*.*"
.Filters.Add "Archivos xls", "*.xls*"
.FilterIndex = 2
.AllowMultiSelect = True
.InitialFileName = ruta
If .Show Then
una = True
For Each ar In .SelectedItems
VariosArchivos.Add ar
Next
For i = VariosArchivos.Count To 1 Step -1
ar = VariosArchivos(i)
Set l2 = Workbooks.Open(ar)
If una Then
l2.Sheets(1).Rows(1).Copy h1.Range("A1")
una = False
End If
u = h1.UsedRange.Rows(h1.UsedRange.Rows.Count).Row + 1
l2.Sheets(1).Range([A2], [A2].SpecialCells(11)).Copy h1.Range("A" & u)
l2.Close False
Next
End If
End With
'
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Seleccione el quinto excel"
.Filters.Clear
.Filters.Add "Todos", "*.*"
.Filters.Add "Archivos xls", "*.xls*"
.FilterIndex = 2
.AllowMultiSelect = False
.InitialFileName = ruta
If .Show Then
ar = .SelectedItems.Item(1)
Set l2 = Workbooks.Open(ar)
l2.Sheets(1).UsedRange.Copy h2.Range("A1")
l2.Close False
End If
End With
Application.ScreenUpdating = True
MsgBox "Fin"
End SubSaludos.Dante Amor
Recuerda valorar la respuesta.
Hola,
Cuando corro el código me marca error de “No se puede pegar la información ya que el área de Copiar y el área de pegado tienen formas distintas..” y me marca error en esta fila:
l2.Sheets(1).Range([A2], [A2].SpecialCells(11)).copy h1.Range("A" & u)
No se si se deba a que los archivos tienen filtros (no están aplicados), no existen celda combinadas y el formato y en todos los archivosse utilizan el mismo número de columnas.
Saludos y gracias
A lo mejor tienes muchas filas y la hoja que está recibiendo ya llegó a su capacidad.
Puedes probar con libros que tengan de 2 a 3 filas, y después de que funcione pruebas con tus archivos completos.
Me sale "Error definido por la aplicación o el objeto", los libros que selecciono tienen en promedio 800 filas de información en promedio.
Probé el macro y si funciona con archivos de 4 filas, pero no funcionan con los míos pero de verdad no se porque, los datos no tienen ninguna fórmula, son puro texto.
Probé quitando los filtros pero me sigue marcando el error de que las áreas de copiado y pegado no coinciden.
Prueba esta
Sub CopiarVariosArchivos()
'Por.Dante Amor
'
Dim VariosArchivos As New Collection
'
Application.ScreenUpdating = False
Set l1 = ThisWorkbook
Set h1 = l1.Sheets(1)
Set h2 = l1.Sheets(2)
h1.Cells.Clear
ruta = l1.Path
'
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Seleccione archivos de excel"
.Filters.Clear
.Filters.Add "Todos", "*.*"
.Filters.Add "Archivos xls", "*.xls*"
.FilterIndex = 2
.AllowMultiSelect = True
.InitialFileName = ruta
If .Show Then
una = True
For Each ar In .SelectedItems
VariosArchivos.Add ar
Next
For i = VariosArchivos.Count To 1 Step -1
ar = VariosArchivos(i)
Set l2 = Workbooks.Open(ar)
If una Then
l2.Sheets(1).Rows(1).Copy h1.Range("A1")
una = False
End If
u = h1.UsedRange.Rows(h1.UsedRange.Rows.Count).Row + 1
ce = l2.Sheets(1).UsedRange.SpecialCells(11).Address
l2.Sheets(1).Range([A2], ce).Copy h1.Range("A" & u)
l2.Close False
Next
End If
End With
'
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Seleccione el quinto excel"
.Filters.Clear
.Filters.Add "Todos", "*.*"
.Filters.Add "Archivos xls", "*.xls*"
.FilterIndex = 2
.AllowMultiSelect = False
.InitialFileName = ruta
If .Show Then
ar = .SelectedItems.Item(1)
Set l2 = Workbooks.Open(ar)
l2.Sheets(1).UsedRange.Copy h2.Range("A1")
l2.Close False
End If
End With
Application.ScreenUpdating = True
MsgBox "Fin"
End Sub
Te puedo enviar un ejemplo de como son mis archivos? Quizá eso ayude, porque este macro me sigue marcando el mismo error.
Necesitas que cree otra pregunta?
No crees otra pregunta.
Envíame tus archivos para revisarlos.
Recuerda poner tu nombre en el asunto.
OK, gracias, te envíe solo uno porque todos los archivos son iguales (solo varían el numero de filas)
Saludos y disculpa las molestias
No tengo problemas con la macro para abrir, copiar y pegar la información del archivo que me diste. Lo único raro que encontré en tu archivo es que en la celda "L46244" tienes un carácter.
Pero si la última columna de los archivos es la "L" y siempre la columna "L" tiene datos en todas las filas, entonces utiliza lo siguiente:
Sub CopiarVariosArchivos()
'Por.Dante Amor
'
Dim VariosArchivos As New Collection
'
Application.ScreenUpdating = False
Set l1 = ThisWorkbook
Set h1 = l1.Sheets(1)
Set h2 = l1.Sheets(2)
h1.Cells.Clear
ruta = l1.Path
'
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Seleccione archivos de excel"
.Filters.Clear
.Filters.Add "Todos", "*.*"
.Filters.Add "Archivos xls", "*.xls*"
.FilterIndex = 2
.AllowMultiSelect = True
.InitialFileName = ruta
If .Show Then
una = True
For Each ar In .SelectedItems
VariosArchivos.Add ar
Next
For i = VariosArchivos.Count To 1 Step -1
ar = VariosArchivos(i)
Set l2 = Workbooks.Open(ar)
If una Then
l2.Sheets(1).Rows(1).Copy h1.Range("A1")
una = False
End If
u = h1.UsedRange.Rows(h1.UsedRange.Rows.Count).Row + 1
u2 = l2.Sheets(1).Range("L" & Rows.Count).End(xlUp).Row
l2.Sheets(1).Range([A2], "L" & u2).Copy h1.Range("A" & u)
l2.Close False
Next
End If
End With
'
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Seleccione el quinto excel"
.Filters.Clear
.Filters.Add "Todos", "*.*"
.Filters.Add "Archivos xls", "*.xls*"
.FilterIndex = 2
.AllowMultiSelect = False
.InitialFileName = ruta
If .Show Then
ar = .SelectedItems.Item(1)
Set l2 = Workbooks.Open(ar)
l2.Sheets(1).UsedRange.Copy h2.Range("A1")
l2.Close False
End If
End With
Application.ScreenUpdating = True
MsgBox "Fin"
End Sub
