EXCEL VBA Busqueda de datos

[leoruizb]

Saludos,

Ya por fin pude poner a trabajar el sistema conectando las dos hojas de calculo entre si. Busco los datos (direccion fisica de las imagenes) en una hoja de calculo que tiene toda la base de datos y esta me genera la ficha y ademas busca y pega las 4 imagenes y las coloca en la ficha en la celda que corresponde.

Ahora solo me queda centrar cada una de las imagenes en la celda respectiva y espero que me den una ayuda. De todas maneras mañana me pondre a buscar en internet a ver si consigo algo que me ayude a resolver esto porque el codigo actual me ubica la imagen en el top de la celda y a la izquierda. Yo la necesito un poco mas pequeña y centrada en la celda.

Aqui les dejo la ultima version del codigo que llevo hasta este momento.
Seguimos en contacto.
bye

Leo

Sub InsertarImagenRango()
' With the macro below you can insert pictures and fit them to any range in a worksheet.
Dim buscar As String
Dim dato As Object, hoja1 As Object
Dim diruc As String, dircad As String, dirp As String, diruf As String
Dim hdato As Workbook

Set hoja1 = Worksheets("Hoja1")
buscar = hoja1.Range("B8")

Set hdato = Workbooks.Open("C:\redgeodesica\datos.xlsx")
Set dato = Worksheets("datos")

diruc = Application.WorksheetFunction.Lookup(buscar, dato.Range("A1:A200"), dato.Range("J1:J200"))
dircad = Application.WorksheetFunction.Lookup(buscar, dato.Range("A1:A200"), dato.Range("K1:K200"))
dirp = Application.WorksheetFunction.Lookup(buscar, dato.Range("A1:A200"), dato.Range("L1:L200"))
diruf = Application.WorksheetFunction.Lookup(buscar, dato.Range("A1:A200"), dato.Range("M1:M200"))

ThisWorkbook.Activate

Insertarimagen diruc, Range("A16")
Insertarimagen dircad, Range("D16")
Insertarimagen dirp, Range("A29")
Insertarimagen diruf, Range("D29")

End Sub

Sub Insertarimagen(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
' position picture
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing
End Sub