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
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 SubRevisa 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. CloseRecuerda valorar la respuesta.
