Macro busque libro a partir de una celda y copie un rango especificó del libro encontrado al libro abierto
Agradeceré infinitamente su ayuda con el siguiente problema que tengo
- Tengo una carpeta en la siguiente ruta “C:\FICHAS” la cual contiene 50 libros de Excel
Nombre de los libros que contiene la carpeta: (Ejemplo 1, Ejemplo 2, Ejemplo 3….. Ejemplo 50)
- Tengo una segunda carpeta en la siguiente ruta “C:\BBDD”, la cual contiene un único libro llamado “PROGRAMA”
- En el libro llamado “PROGRAMA” tengo 5 hojas.
- Dentro de la columna “D” de la HOJA 3 a partir de la fila 4 puedo tipiar el nombre de un libro que este guardado en la carpeta FICHAS dentro de la ruta “C:\FICHAS”
- Si el libro tipiado ( ejemplo 1) es encontrado dentro de la ruta anteriormente indicada, copie el contenido del rango B30: L30 de libro encontrada, al frente de la celda de la columna “D” de la hoja tres del libro llamado “PROGRAMA” desde el cual fue buscado, y copie el contenido del rango B40:L40 libro encontrado ( ejemplo 1) a la hoja 4 del libro llamado “PROGRAMA” en la misma fila en la cual pego en la hoja 3 ( o en la primer fila encontrada vacía o en blanco) a partir de la columna "d" fila 4
- En el caso que el libro buscado no exista salga un mensaje con el dialogo ficha no existe,
- Y así continúe buscando más libros que hayan sido tipiados en la columna “D” de la hoja 3 del libro llamado “PROGRAMA” hasta que encuentre una celda bacía.
La macro puede ser automática, es decir asociada a un botón al hacer clic sobre este, una vez tipiados todos los libros que quiero buscar en la columna “D”, empiece a realizar los procesos anteriormente indicados.
O también la macro puede ser manual, es decir, pongo un botón al frente de cada celda a partir de la fila 4 de la hoja tres del libro programa, el cual se ejecutara al hacer clic comenzando a buscar el libro indicado en la celda que esta frente a ese botón.
Si me ayudan con este tema quedare profundamente agradecido xq me ahorraran muchísimo tiempo en mi rutina diaria, la cual me toma todo el día
1 Respuesta
Te anexo la macro.
Cuando ejecutas la macro te aparece un mensaje: Si quieres que se lean todos los libros, presiona el botón "Sí", si solamente quieres leer un libro, presiona el botón "No".
Sub CopiarRango()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'
Set l1 = ThisWorkbook
Set h3 = l1.Sheets(3)
Set h4 = l1.Sheets(4)
res = MsgBox("Leer todos los libros : presiona Sí" & vbCr & _
"Leer el libro seleccionado : presiona No" & vbCr & _
"Cancelar el proceso : Presiona Cancelar", vbYesNoCancel, "COPIAR RANGO")
'
Select Case res
Case vbYes
i = 4
f = h3.Range("D" & Rows.Count).End(xlUp).Row
If f < 4 Then
MsgBox "No hay libros después de la fila 3", vbExclamation
Exit Sub
End If
Case vbNo
If Selection.Column <> Columns("D").Column Then
MsgBox "Debes seleccionar una celda de la Columna D", vbExclamation
Exit Sub
End If
If Selection.Row < 4 Then
MsgBox "Debes seleccionar una fila mayor a 3", vbExclamation
Exit Sub
End If
i = Selection.Row
f = Selection.Row
Case vbCancel
Exit Sub
End Select
'
celda = ActiveCell.Address
h3.Range("E" & i & ":O" & f).ClearContents
For j = i To f
ruta = "C:\fichas\"
'ruta = "C:\trabajo\fichas\"
arch = h3.Cells(j, "D") & ".xlsx"
If Dir(ruta & arch) = "" Then
h3.Cells(j, "E") = "Archivo no existe"
Else
Set l2 = Workbooks.Open(arch)
Set hx = l2.Sheets(1)
k = h4.Range("D" & Rows.Count).End(xlUp).Row + 1
If k < 3 Then k = 4
hx.Range("B30:L30").Copy
h3.Cells(j, "E").PasteSpecial Paste:=xlValues
hx.Range("B40:L40").Copy
h4.Cells(k, "D").PasteSpecial Paste:=xlValues
l2.Close False
End If
Next
h3.Select
Range(celda).Select
Application.ScreenUpdating = True
MsgBox "Proceso terminado", vbInformation
End SubPrueba la macro, cualquier detalle avísame.
S a l u d o s . D a n t e A m o r
Recuerda valorar la respuesta.
Gracias estimado Dante por su tiempo.
Al tratar de correr el macro me arroja el error 1004 deteniéndose el macro en la siguiente línea después del ELSE:
Set l2 = Workbooks.Open(arch).
Que estoy hacienda mal?
¿Tienes el archivo protegido?
Qué extensión tiene tu archivo, yo le puse xlsx, si solamente es xls, entonces cambia en la macro
arch = h3.Cells(j, "D") & ".xlsx"
Por
arch = h3.Cells(j, "D") & ".xls"
Puedes poner el mensaje de error completo.
