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

  1. 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)

  1. 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

Respuesta
1

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 Sub

Prueba 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.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas