Necesito una Macro que me permita en excel Insertar una foto automáticamente, de acuerdo a un código asignado a una celda.

Para poder realizar tu petición debes pegar este código en la Hoja3 del explorador de proyectos:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim variable As String

variable = Range("B16").Value
carpeta = "C:\Usuarios\José Agüero\Mis documentos\COP"
Range("N16").Select
ActiveSheet.Pictures.Insert(carpeta & variable & ".JPG").Select

Range("N23").Select
ActiveSheet.Pictures.Insert(carpeta & variable & ".JPG").Select

Range("N35").Select
ActiveSheet.Pictures.Insert(carpeta & variable & ".JPG").Select

End Sub

Ten en cuenta que el nombre de los archivos de las fotos deberá ser el mismo del código del funcionario (B16) y la extensión JPG (lo puedes cambiar si quieres)

Me dejé un separador, es:

carpeta = "C:\Usuarios\José Agüero\Mis documentos\COP\"

Buenas Tardes. Amigo Gregorio. Estoy altamente agradecido por su Atención. pero he tenido algunos problemas en la ejecución del Macro: Aplique el Código Macro que me envió, pero no me corre. No hace nada. las Imágenes que tengo son JPEG, no se si eso influye en la ejecución. Cuando le pido las Propiedades a la foto me dice que es JPEG (JPG); no se si ese será el Problema.!

Ya revise que las Imágenes deben tener el mismo nombre del Código.!  Ya Revise la Ruta; pero no me da las fotos. 

¿Has probado cambiar JPG por JPEG en la macro?

Buenas Noches. Aun no he logrado que me funcione. es importante que sepa que no soy bueno en esto, digo esto por si piensas que debo conocer el resto de información adicional, he tomado los códigos tal y como los envió, probé con el cambio de la extensión del archivo de la foto .jpg y la .jpeg; pero sigo sin signos; no me muestra la foto.

Cambie la ruta, la puse mas corta; estoy utilizando la ruta: ("C:\COP\" & nombre & ".jpeg"); pero inclusive no se si le falta o si le puse algún caracteres de mas. También la utilice  sin  los  paréntesis "C:\COP\" & nombre & ".jpeg"; y Nada no funciona.

Creo que lo mejor sera que cuelgues el archivo en dropbox y le hecho un vistazo.

El lunes tendré acceso para poder revisar y dar una respuesta más ampliada

Hola, mis saludos, amigo Gregori... Por normas de seguridad no es buena idea utilizar Dropbox. Tu sugerencia inicial de tu respuesta quiero saber si funciona en algún archivo similar; porque sigo revisando a ver si funciona. No me doy por vencido y quiero que funcione de la mejor forma. Solo quiero que la Macro me presente la foto de una funcionario a través de un código que se asigna a cada funcionario que igual es el nombre de la foto. Sugiero que revisemos con calma.

Ya te subire el archivo que he utilizado yo. Por el tema de seguridad podrias subir un archivo con la misma estructura pero datos y fotos inventados

Intentaré ser lo más detallado posible. He modificado la macro para que te sea mas fácil, la macro es:

La macro la tienes que pegar en la Hoja donde tengas el código de funcionario que va a designar la foto

En mi ejemplo la he pegado en la Hoja1 que es donde se ejecuta la macro

Private Sub Worksheet_Change(ByVal Target As Range)

Dim img As Shape

Dim variable As String

On Error GoTo fin:

If Not Intersect(Target, Range("$A$1")) Is Nothing Then

For Each img In ActiveSheet.Shapes

If img.Type = 11 Then img.Delete

Next

If Range("A1").Value = "" Then Exit Sub

variable = Range("A1").Value

carpeta = "C:\"

Sheets("Hoja1").Select

Range("M1").Select

ActiveSheet.Pictures.Insert(carpeta & variable & ".JPG").Select

Exit Sub

fin:

MsgBox "La foto no existe"

Else

End If

End Sub

La explicación de las órdenes importantes para tu comprensión y puedas modificarlas para adaptarlas a tu excel son:

‘Si hay un error ve a fin. Sirve para si pones un código de funcionario que no existe su foto (no hay foto con ese número.JPG) saltará hasta llegar a fin:, donde te dará un mensaje diciendo que “La foto no existe”

On Error GoTo fin:

‘Si la celda que se cambia es A1 se ejecutará la macro, sino nada. Debes cambiar A1 por la celda que necesites

If Not Intersect(Target, Range("$A$1")) Is Nothing Then

‘Las siguientes tres líneas valen para borrar las imágenes que haya en la hoja, ya que vamos a insertar una nueva y no queremos que se ponga encima de la anterior (si la hubiese)

For Each img In ActiveSheet.Shapes

If img.Type = 11 Then img.Delete

Next

‘La siguiente línea sirve para que no haga nada en el caso de que borres el contenido de la celda A1.

If Range("A1").Value = "" Then Exit Sub

‘La siguiente línea identifica que celda tien el código del funcionario. La deberás cambiar

variable = Range("A1").Value

‘Aqui definimos la ruta donde están las fotos. La deberás cambiar y no olvidarte el \ del final

carpeta = "C:\"

‘Esta orden sirve para decir que hoja queremos seleccionar. Lo deberás modificar

Sheets("Hoja1").Select

‘Esta orden para decir en qué celda quiero que se inserte la imagen. La deberás cambiar

Range("M1").Select

‘Esta añade la imagen

ActiveSheet.Pictures.Insert(carpeta & variable & ".JPG").Select

Exit Sub

fin:

MsgBox "La foto no existe"

Else

End If

End Sub

Si quieres probar la macro antes de tocar nada para ver su funcionamiento, pon dos imágenes en C:\ que se llamen 1.JPG y 2.JPG

Copia la macro en la Hoja1 del Explorador de proyectos (Alt+F11 para acceder a el desde excel)

Ve a la Hoja1 y cambia el valor de la celda A1, pon 1,2,3, borra el valor, 2,9 y verás su funcionamiento

Hay varios casos que contempla la macro que en resumen son:

• Pones un numero de funcionario que existe la imagen con ese numero y borra si hay alguna imagen en la Hoja1 y inserta la nueva
• Pones un numero de funcionario que NO existe la imagen con ese numero y da un mensaje de que la foto no existe
• Borras el contenido de la celda A1 y borra las fotos (no hace nada mas)
• Modificas una celda diferente de A1 y no hace nada

https://www.dropbox.com/s/qvw8m450twal94o/Fotos.xlsm?dl=0

EXCELENTE;  Estuve trabajando en el Archivo que me informó y funciona muy bien... con la observación que la acción que se ejecuta es de inserción; lo que implica que cada vez que modifico la celda A1 se monta otra foto; y eso no me conviene porque cada vez que se modifique el archivo de las estadísticas me va a cambiar la foto automáticamente. Me explico, Ayer estaba PEDRO en primer lugar, pero luego de agregar mas información a la sábana de los reportes de cada funcionario posiblemente JOSÉ tome el primer lugar en reemplazo de Pedro, por que el archivo lo hace a través de una formula.

Lo otro es que necesito saber si la foto la puedo recibir o presentar utilizando un `Control ActiveX´, con la finalidad de ubicarla en un sitio específico dentro de la Hoja.

Ya le califique EXCELENTE su respuesta; dime si necesitas que mi persona realizar otra pregunta.?

Altamente agradecido por su apoyo. Estamos en contacto.

Disculpa voy a tratar de enviarte una gráfica de mi archivo....

La calidad de la imagen la hace ilegible...

Para poder realizarlo, debes borrar las líneas en negrita, así cada vez que haya un cambio en cualquier lugar de la hoja, borrará la foto existente y añadirá la que corresponda a la persona en el primer lugar de la lista.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim img As Shape

Dim variable As String

On Error GoTo fin:

If Not Intersect(Target, Range("$A$1")) Is Nothing Then

For Each img In ActiveSheet.Shapes

If img.Type = 11 Then img.Delete

Next

If Range("A1").Value = "" Then Exit Sub

variable = Range("A1").Value

carpeta = "C:\"

Sheets("Hoja1").Select

Range("M1").Select

ActiveSheet.Pictures.Insert(carpeta & variable & ".JPG").Select

Exit Sub

fin:

MsgBox "La foto no existe"

Else

End If

End Sub

Amigo Gregory... Buenas tardes. me disculpa tanta molestia. pero sigo obteniendo casi que el mismo resultado. No me esta colocando la foto en el lugar que yo deseo. Quisiera realmente terminar este proyecto, el cual es de ayuda para mi desempeño en donde presto mis servicio de Funcionario Público y creame que nos hace falta, activarlo; puesto que nos ayuda, no solo en esta actividad. Se puede adaptar a otras actividades. También realice la prueba que me informó barrando algunas líneas de la última información que me dio. Pero no me borra la foto de cambiarse el código.

Necesito que la foto aparezca o se presente, pero que no se inserte en el archivo porque se montaría tantas veces como se actualice o se cambie automáticamente el código del funcionario en las celdas destinadas (B16, B17 y la B18) tal como lo presento en la Imagen.

De antemano le doy las gracias por su apoyo. Seguiremos en contacto.

Te dejo en dropbox el archivo que a mi me funciona

https://www.dropbox.com/s/tqbpwhkw42bra0k/Fotosflores.xlsm?dl=0 

La macro está en la Hoja1 y es:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim img As Shape
Dim variable As String
Dim carpeta As String
Dim siguiete As Integer

On Error GoTo fin

For Each img In ActiveSheet.Shapes
If img.Type = 11 Then img.Delete
Next

carpeta = "C:\"
siguiente = 0

For Each c In Worksheets("Hoja1").Range("B16:B18")
Range("N" & siguiente + 11).Select
ActiveSheet.Pictures.Insert(carpeta & c.Value & ".JPG").Select
siguiente = siguiente + 12
Next

Exit Sub

fin:

MsgBox "La foto no existe"

End Sub

Deberás cambiar los datos en negrita por tus datos

Recuerda que el nombre de las fotos, debe ser el codigo de los funcionarios que tienes en B16, B17 y B18 y deben estar todas en la misma carpeta que defines en:

carpeta = "C:\"

y aqui tienes que poner el nombre de tu hoja donde tienes los datos

For Each c In Worksheets("Hoja1").Range("B16:B18")

Disculpa mi tardanza, estuve desconectado por algunos días y averiguando otras formas y conseguí esta macro; pero no la entiendo; quiero compartirla contigo para que la analices y me digas si también puede funcionar o adaptarse a lo que deseamos; este macro me funciona a la perfección en otro archivo, pero debo mantener las fotos en otros archivo excel abierto llamado FOTOS, para que funcione la macro.

Mi pregunta es si puedo mantener las fotos en una HojaX del mismo archivo que estoy trabajando o necesariamente debe ser en otro archivo; este comentario no es otra pregunta es pedir mas información relativo al mismo archivo que inicialmente vengo trabajando.

Que lastima no poder compartir éste archivo con su persona; pues hasta ahora Usted es quien ha podido dar con ciertas pistas de lo que se desea hacer. lo otro es que me doy cuenta que no hace falta la función de Control de Imagen.

Bueno ésta es la Macro que le referí al inicio:

Dim numordenados As New Collection
Dim cuentaordenados As New Collection
Dim numeros As New Collection
Sub destacado()
Set h2 = Sheets("Hoja2")
Set h3 = Sheets("Hoja3")
Set rango = h2.Range("I12:J240")
Set cuentaordenados = Nothing
c1 = 0: c2 = 0: c3 = 0: c4 = 0: c5 = 0
For Each c In rango
If c.Value <> "" Then agrega c.Value
Next
For i = 1 To numordenados.Count
num = numordenados(i)
c1 = Application.CountIf(rango, num)
cuenta c1, num
Next
f = 13
y = 4
x = cuentaordenados.Count
If x < 4 Then
y = x - 1
End If

For i = cuentaordenados.Count To cuentaordenados.Count - y Step -1
cantidad = cuentaordenados(i)
numero = numeros(i)
h3.Cells(f, "B") = numero
f = f + 1
Next
'Inserta la foto del número 1
ponerfoto
End Sub
Sub agrega(n)
'Por.Dante Amor
For m = 1 To numordenados.Count
If numordenados(m) > n Then
'si el número almacenado es mayor lo almacena antes
numordenados.Add n, before:=m
Exit Sub
ElseIf numordenados(m) = n Then Exit Sub
End If
Next
numordenados.Add n 'si es el mayor de todos lo agrega al final
End Sub
Sub cuenta(n, y)
'Por.Dante Amor
For m = 1 To cuentaordenados.Count
If cuentaordenados(m) >= n Then
cuentaordenados.Add n, before:=m
numeros.Add y, before:=m
Exit Sub
End If
Next
cuentaordenados.Add n 'si es el mayor de todos lo agrega al final
numeros.Add y
End Sub

Espero sea de Ayuda para otras personas con similar necesidad.!!!

Estamos a la orden.

Esta macro es de Dante Amor, persona muy activa en esta web. Mejor pregúntele a él

Cierto a él le debo esa información, quien en vida ayudó a mucha gente; ahora creo que es su hijo quien esta a cargo; ya le pedí también la información, pero fue infructuoso el resultado. muchas personas entre ellas, mi persona lo sigo en su cuenta lamentó su partida inesperada... Gracias por todo.