Macro para buscar datos en varios libro compartidos en red

Hey, que tal expertos!

Buenas noches!,

Tengo la necesidad de buscar datos en archivos compartidos de un usuario en red, el cual tiene dos carpetas compartidas, una carpeta tiene contraseña de acceso y solo yo tengo el permiso para acceder a ella. La otra carpeta esta visible para todos los usuarios, requiero hacer consultas en ambas carpetas.

1. Lo primero que necesito es que la macro vaya a la carpeta sin contraseña, abra el libro que contiene los datos generales de la empresa y busque los datos del cliente seleccionado.

2. Luego, que seleccione la carpeta que tiene contraseña, abra el libro que contiene los importes de credito y busque el monto que corresponde al cliente selecionado.

3. Y Por último que vaya a mi archivo y busque el resto de datos relacionados con dicha consulta.

Es algo complicado para mi, agradeceria mucho un ejemplo de como debe ir el código en la macro para que posteriomente solo tenga que hacer las adaptaciones, muchas gracias por la atención y espero haberme explicado, de cualquier modo estoy a la orden.

Nota: El usuario al que deseo conectarme está en mi mismo grupo de trabajo.

Anexo esta macro que tengo para su modificación

.

Sub codcodigo()

application.DisplayAlerts = False
application.ScreenUpdating = False

'Esta es la hoja donde ejecuto mi consulta
codigo = Cells(3, 8)
Sheets("Consulta").Cells(5, 4) = Empty 'Progrma
Sheets("Consulta").Cells(3, 4) = Empty ' Nivel
Sheets("Consulta").Cells(3, 2) = Empty 'Muni
Sheets("Consulta").Cells(3, 6) = Empty 'importe
Sheets("Consulta").Cells(5, 2) = Empty 'Nombre obra
Sheets("Consulta").Cells(7, 2) = Empty ' Loc
Sheets("Consulta").Cells(11, 2) = Empty 'Descrp
Sheets("Consulta").Cells(7, 4) = Empty     'Credito

Sheets("Consulta").Cells(9, 4) = Empty ' No de contrato
Sheets("Consulta").Cells(9, 2) = Empty 'CCt
Range(Cells(15, 2), Cells(500, 8)).ClearContents

 

Sheets("DATOS GENERALES"). Activate 'Este es el nombre del libro compartido del usuario en red al que deseo abrir para buscar los datos que abajo se describen, y la ruta de acceso a la carpeta compartida sin contraseña donde se encuentra es: \\PEDRO\EMPRESA_2014\DATOS GENERALES

Set FILA = Cells.Find(What:=codigo)

If FILA Is Nothing Then

MsgBox "El código no existe en la Base de Datos"
Sheets("Consulta").Activate
Else
FILA = Cells.Find(What:=codigo).Row
Sheets("Consulta").Cells(5, 4) = Cells(FILA, 6) 'Progrma
Sheets("Consulta").Cells(3, 4) = Cells(FILA, 7) ' Nivel
Sheets("Consulta").Cells(3, 2) = Cells(FILA, 8) 'Muni
Sheets("Consulta").Cells(3, 6) = Cells(FILA, 22) 'El valor de esta celda es el único dato que debe buscar en el libro que se ubica en la carpeta compartida la cual tiene contraseña y la ruta de acceso es: \\PEDRO\CREDITOS_2014\IMPORTES, la contraseña es "123".

Sheets("Consulta").Cells(5, 2) = Cells(FILA, 9) 'Nombre obra
Sheets("Consulta").Cells(7, 2) = Cells(FILA, 10) ' Loc
Sheets("Consulta").Cells(11, 2) = Cells(FILA, 12) 'Descrp
Sheets("Consulta").Cells(7, 4) = Cells(FILA, 26) 'Of-autor
Sheets("Consulta").Cells(9, 4) = Cells(FILA, 27) ' No de contrato
Sheets("Consulta").Cells(9, 2) = Cells(FILA, 5) 'CCt
Sheets("RESUMEN"). Activate 'Este es el nombre de la hoja de mi archivo donde busca los datos abajo descritos para terminar de complementar la información del cliente.
r = 2
t = 15
Do While Cells(r, 2) <> Empty

If Cells(r, 1) = codigo Then
Sheets("Consulta").Cells(t, 2) = Cells(r, 9) 'concepto
Sheets("Consulta").Cells(t, 3) = Cells(r, 17) ' total de articulos
Sheets("Consulta").Cells(t, 4) = Cells(r, 18) ' costo total
Sheets("Consulta").Cells(t, 5) = Cells(r, 13) ' requisicion
Sheets("Consulta").Cells(t, 6) = Cells(r, 14) ' giro
Sheets("Consulta").Cells(t, 7) = Cells(r, 19) ' fecha
Sheets("Consulta").Cells(t, 8) = Cells(r, 26) ' Precio unit
t = t + 1
End If
r = r + 1
Loop
Sheets("Consulta").Activate
Exit Sub
End If

End Sub

1 respuesta

Respuesta
1

Puedes enviarme los archivos que se van a ocupar y me explicas en el archivo que lleva la macro con un ejemplo de lo que necesitas.

Recuerda poner en el asunto tu nombre "intrepido"

Muchísimas gracias!

He enviado los archivos solicitados a tu mail

Atentamente

Intrepido21

Te envié el archivo para que la macro busque el cliente seleccionado, así quedó la macro:

Sub codcodigo()
'Mod.Por.DAM
    application.DisplayAlerts = False
    application.ScreenUpdating = False
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets("Consulta")
    codigo = h1.Cells(3, 8)
    h1.Cells(5, 4) = Empty 'Programa
    h1.Cells(3, 4) = Empty ' Nivel
    h1.Cells(3, 2) = Empty 'Municipio
    h1.Cells(3, 6) = Empty 'Monto de origen
    h1.Cells(5, 2) = Empty 'Nombre obra
    h1.Cells(7, 2) = Empty ' Localidad
    h1.Cells(11, 2) = Empty 'Descripción de la obra
    h1.Cells(7, 4) = Empty 'Of-Autorizacion
    h1.Cells(9, 4) = Empty ' No de contrato
    h1.Cells(9, 2) = Empty 'Subsistema
    h1.Range(h1.Cells(15, 2), h1.Cells(500, 8)).ClearContents
    ruta = "\\PEDRO\EMPRESA_2014\DATOS GENERALES"
    'ruta = ThisWorkbook.Path
    Set l2 = Workbooks.Open(ruta & "\EMPRESAS_2014A")
    For Each h In l2.Sheets
        Set b = h.Cells.Find(codigo, Lookat:=xlWhole)
        If Not b Is Nothing Then
            existe = True
            Exit For
        End If
    Next
    If existe Then
        H1.Cells(5, "D") = h. Cells(b.Row, "A") 'Programa
        h1.Cells(3, "D") = h. Cells(b.Row, "E") ' Nivel
        h1.Cells(3, "B") = h. Cells(b. Row, "F") 'Municipio
 'h1.Cells(3, 6) = h. Cells(b. Row, 22) 'Monto de origen
 'h1.Cells(5, 2) = h. Cells(b. Row, 9) 'Nombre obra
 'h1.Cells(7, 2) = h. Cells(b. Row, 10) ' Localidad
 'h1.Cells(11, 2) = h. Cells(b. Row, 12) 'Descripción de la obra
 'h1.Cells(7, 4) = h. Cells(b. Row, 26) 'Of-autorizacion
 'h1.Cells(9, 4) = h. Cells(b. Row, 27) ' No de contrato
 'h1.Cells(9, 2) = h. Cells(b. Row, 5) 'Subsistema
        Set h3 = l1.Sheets("RESUMEN")
        r = 2
        t = 15
        Do While h3.Cells(r, 2) <> Empty
            If h3.Cells(r, 1) = codigo Then
                H1.Cells(t, 2) = h3. Cells(r, 9) 'Articulo
                H1.Cells(t, 3) = h3. Cells(r, 17) ' Cantidad total
                H1.Cells(t, 4) = h3. Cells(r, 18) ' Importe total estimado
                H1.Cells(t, 5) = h3. Cells(r, 13) ' requisicion
                H1.Cells(t, 6) = h3. Cells(r, 14) ' giro
                H1.Cells(t, 7) = h3. Cells(r, 19) ' fecha
                H1.Cells(t, 8) = h3. Cells(r, 26) ' Importe total adjudicado
                t = t + 1
            End If
            r = r + 1
        Loop
    Else
        MsgBox "No Existe El Código: " & codigo, vbExclamation
    End If
    l2.Close
End Sub

Revisa el resultado.

Recuerda valorar la respuesta

Muchísimas gracias!

He realizado las adaptaciones y la macro funciona bien, solo falta obtener un dato del libro "IMPORTES.xlxs". envío archivo de nuevo.

Que tengas una excelente tarde!

Te envíe el archivo con el complemento, que sería esta parte:

 'Busca monto de origen
    ruta = "\\PEDRO\CONFIDENCIAL\"
    ruta = ThisWorkbook.Path
    Set l3 = Workbooks.Open(ruta & "\IMPORTES")
    Set h3 = l3.Sheets(1)
    Set b = h3.Columns("K").Find(codigo, Lookat:=xlWhole)
    If Not b Is Nothing Then
        h1.Range("F3") = h3.Cells(b.Row, "DK")
    End If
    L3. Close

Recuerda valorar la respuesta.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas