Combinar los datos de varios libros en otro libro en Excel (2013)
Tenía creada una macro para recorrer carpetas anidadas y copiar datos de todos los archivos .xlsm, que recorría las carpetas usando la instrucción Dir(). Sin embargo, con el office2013 no me funciona, porque al ejecutar
Folder = "D:\ds02065\Escritorio\proyecto\Germany Bends\*.xlsm"
Filename = Dir(Folder, vbArchive)
La línea Filename se me queda vacía (" ").
Así que he buscado una alternativa, usando el siguiente código:
Sin embargo, no funciona. Si quito todo lo que viene después del . Open en copia(FileName), el programa funciona correctamente: recorre el directorio y me abre todos los libros. Pero si dejo aunque sea sólo la línea . Close, sólo se me abren 2 libros (los que están en el primer nido) y tampoco se cierran.
¿Alguien tiene una idea de dónde está el fallo?
En esta línea tienes un par de problemas:
Workbooks(libro). Worksheets(hoja).Cells(fila, j) = Workbooks(Filename). Worksheets(hoja). Cells(i, j)
Al inicio de la macro copia(filename) estás declarando la variable fila:
Dim fila As Integer
Entonces fila es igual a 0, por consiguiente, cuando utilizas .cells(fila, j) estás tratando de poner un dato en la fila 0, esa fila no existe, entonces te envía un error.
Para solucionar este detalle tienes que poner el valor de fila después de la hoja, por ejemplo, si vas a escribir después de la última fila, podría ser así:
Fila = Workbooks(Libro). Sheets(Hoja).Range("A" & Rows. Count).End(xlUp). Row + 1Otro detalle es, si en el libro que abriste no tiene una hoja llamada "B-Ends", también te va a enviar un error. Podrías resolverlo, revisando cada hoja del libro abierto, si tiene una hoja con ese nombre, entonces copiar los datos, si no tiene una hoja con ese nombre, entonces cerrarlo.
Bien, otro problema en tu macro, tienes 3 ciclos for anidados, el primero va de 9 a 1000, 991 veces, el segundo va de 1 a 70, entonces 991 * 70 = 69,370 veces, el último va de 1 a 176, entonces 69,370 * 176 = 12,209,120 (doce millones de veces), eso significa que tu ciclo se repite 12 millones de veces. Lo voy a cambiar a copiar y pegar.
Te anexo el código actualizado, prueba y me comentas
Sub abrir()
Application.ScreenUpdating = False
Ruta = "C:\trabajo\"
Call Mostrar_Archivos(Ruta)
Application.ScreenUpdating = True
MsgBox "Fin"
End Sub
'
Sub Mostrar_Archivos(Ruta)
libro = ThisWorkbook.Name
hoja = "B-Ends"
wruta = Ruta
'
Dim fs As Object, carpeta As Object, archivo As Object, subcarpeta As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set carpeta = fs.GetFolder(wruta)
'
If wruta = "" Then
Exit Sub
ElseIf Right(wruta, 1) <> "\" Then
wruta = wruta & "\"
End If
For Each archivo In carpeta.Files
If LCase(Right(archivo.Name, 4)) = "xlsm" Then
FileName = wruta & archivo.Name
Call copia(FileName)
End If
Next
'
For Each subcarpeta In carpeta.subfolders
Call Mostrar_Archivos(subcarpeta)
Next
End Sub
'
Sub copia(FileName)
'Act.Por.Dante Amor
'
Dim Fila As Integer
'
'Libro = ThisWorkbook.Name
Set l1 = ThisWorkbook
hoja = "B-Ends"
Set h1 = l1.Sheets(hoja)
Fila = h1.Range("A" & Rows.Count).End(xlUp).Row + 1
'
Set l2 = Workbooks.Open(FileName)
'Revisa hoja
existe = False
For Each h In l2.Sheets
If LCase(h.Name) = LCase(hoja) Then
existe = True
Exit For
End If
Next
If existe Then
Set h2 = l2.Sheets(hoja)
'Copia datos
u2 = h2. Cells(Rows. Count, 1).End(xlUp). Row
h2. Range(h2.Cells(9, "A"), h2. Cells(u2, 176)). Copy
h1. Cells(Fila, "A").PasteSpecial xlValues
u1 = h1. Cells(Rows. Count, 1).End(xlUp). Row
h1. Range(h1. Cells(Fila, 22), h1. Cells(u1, 22)).Value = FileName
End If
Application.DisplayAlerts = False
l2.Close False
End Sub.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
¡Gracias! ¡Ahora sí!
Hola Dante,
¿Cómo debería hacer para que al abrirse cada archivo no me salte el mensaje de si deseo actualizar los vínculos?
He probado con:
Application.Interactive = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Pero sigue saltando al abrir cada uno de los archivos.
Gracias y un saludo,
Bea
Agrega esta:
Application.AskToUpdateLinks = False
También cambia esta línea
Set l2 = Workbooks.Open(FileName)
Por esta:
Set l2 = Workbooks.Open(Filename, UpdateLinks:=False)
sal u dos
Gracias Dante. Funciona, pero cuando acaba de ejecutarse el programa (tras cerrar el Fin), se queda bloqueado el libro.
He cambiado parte del código Mostrar_Archivos(Ruta) para que, antes de abrir el libro, compruebe si han sido copiados sus datos con anterioridad. No sé si irá por ahí el problema.
For Each archivo In carpeta.Files
NOMBRE = archivo.Name
Rutaynombre = wruta & NOMBRE
ultimafila = ThisWorkbook.Worksheets(Hoja).Cells(Rows.Count, 1).End(xlUp).Row
Posicion = InStr(archivo.Name, "LeadOperatorSummary")
If Posicion <> 0 Then
For i = 9 To ultimafila
Nombrearchivado = ThisWorkbook.Worksheets(Hoja).Cells(i, 1).Value
If Nombrearchivado = Rutaynombre Then contador = contador + 1
Next
If contador = 0 Then
FileName = wruta & archivo.Name
Call copia(FileName)
On Error Resume Next
End If
contador = 0
End If
Next
Un saludo
Bea
¿Probaste sin tus cambios?
