Completar macro para insertar imagen en celda...

Solo consultas sobre macros y código VBA Excel.
Reglas del Foro
1. Antes de hacer tu pregunta intenta con el buscador de este foro (muchas preguntas ya fueron respondidas antes!)
2. Si haces una nueva pregunta, es muy recomendable que adjuntes el ejemplo Excel para poder comprenderla mejor!
3. Realiza tu pregunta de forma clara, explicando bien cada paso de lo que haces y tendrás más probabilidad de respuesta!
Responder
Avatar de Usuario
Gabriel Marq
Miembro Frecuente
Miembro Frecuente
Mensajes: 5
Registrado: 12 Oct 2019 12:13

Completar macro para insertar imagen en celda...

Mensaje por Gabriel Marq » 12 Oct 2019 12:17

Buen dia amigos del foro, utilizo el siguinte codigo vba para insertar automaticamente imagenes en celdas especificas de una matrix de datos...
________________________________________________________________________
If Not Intersect(Target, Range("B1")) Is Nothing Then

On Error Resume Next
For Each shp In ActiveSheet.Shapes
shp.Delete
Next shp
ActiveSheet.Range("E4").Select
Do While ActiveCell.Offset(0, -1).Value <> Empty
Set RangoImagen = ActiveCell.Offset(0, -1)
ActiveSheet.Pictures.Insert (RutaActual & "/CARPETAX/" & RangoImagen.Value & ".jpg")
ActiveCell.Offset(1, 0).Select
Loop
Range("B4").Select
On Error GoTo 0
Exit Sub

End If
_________________________________________________________________________

En terminos generales el codigo lee el nombre de un imagen escrito en una columna, busca en una carpeta especifica en la ubicacion del archivo y la coloca en la celda contigua a esta. La pregunta es simple, que linea debo insertar antes del LOOP para que en caso de que no exista imangen disponible en la carpeta, seleccione una imagen predefinina y la ponga en su lugar.



Avatar de Usuario
Héctor Miguel
Miembro Frecuente
Miembro Frecuente
Mensajes: 5894
Registrado: 26 Mar 2005 18:31

Re: Completar macro para insertar imagen en celda...

Mensaje por Héctor Miguel » 12 Oct 2019 18:01

notas previas:

1) eliminar "shapes" SIN determinar de que tipo... puede corromper la hoja para los otros tipos
(p.ej. la hoja no vuelve a mostrar desplegables en celdas con validacion por lista)

2) si quieres eliminar (SOLO) "imagenes" incrustadas, usa simplemente:

Código: Seleccionar todo

activesheet.pictures.delete
(si no hay pictures, no hace nada)

3) no es claro el por que de la condicion del => Intersect(target, range("b1")) -???-
- ni la intencion o la necesidad de la instruccion: => Exit Sub (???)
- tampoco es necesario ".Select"(ionar) objetos para administrar sus propiedades y demas

suponiendo que desde [E4] hacia abajo existe mas de una celda "con datos", prueba con algo +/- como:

Código: Seleccionar todo

  dim celda as range, laFoto as string, estaFoto as string, imagen as string
  activesheet.pictures.delete
  laFoto = "ruta a la imagen por omision.jpg" ' <= AJUSTA '
  for each celda in range([e4], [e4].end(xldown))
    estaFoto = rutaactual & "\carpeta X\" & celda.offset(, -1) & ".jpg"
    if dir(estaFoto) <> "" then imagen = estaFoto else imagen = laFoto
    with activesheet.pictures.insert(imagen)
      .left = celda.left: .top = celda.top: end with
  next



Avatar de Usuario
Gabriel Marq
Miembro Frecuente
Miembro Frecuente
Mensajes: 5
Registrado: 12 Oct 2019 12:13

Re: Completar macro para insertar imagen en celda...

Mensaje por Gabriel Marq » 17 Oct 2019 12:09

Gracias por la idea amigo Héctor Miguel, la pondre en practica a ver y me disculpo pues no coloque el codigo completo, al verlo entenderas el porque de la instruccion "Exit Sub" que es solamente para que al terminar de ejecutarse el cursor se ubique en una celda al princio de la hoja, igualmente que la condicion del => Intersect(target, range("b1")) es para la ejecucion de la macro con la aplicacion de un doble clic en celda "B1". En lo referente a "Select" como notaras es necesario para que la macro busque en la celda especifica el nombre del archivo de imagen a partir del comenzara a buscar y donde lo debe insertar. Se que es posible modificar la macro para que al referise a la celda donde se ubica el nombre del archivo y lo compare con los que estan en la carpeta "CARPETAX" usando la funcion IF para que en caso de encontrar la correspondiente la coloque en su lugar y en caso de no haber, coloque una en especifica es decir ejemplo "no-photo.jpg" de todas formas gracias, aunque seguro es solo un par de lineas, creo que para no complicarme tendre que escribir uno nuevo}, pero si tienes alguna sugerencia, sera bien recibida, aca dejo el codigo completo... :arrow:
Option Explicit
'
'Arcan@ Master
'Version 8.5 Mar2018
'
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Dim CeldaActual As String
Dim RutaActual As String
Dim RangoImagen As Range
Dim shp As Object

CeldaActual = ActiveCell.Address
RutaActual = ThisWorkbook.Path

If Not Intersect(Target, Range("B1")) Is Nothing Then

On Error Resume Next
For Each shp In ActiveSheet.Shapes
shp.Delete
Next shp
ActiveSheet.Range("E4").Select
Do While ActiveCell.Offset(0, -1).Value <> Empty
Set RangoImagen = ActiveCell.Offset(0, -1)
ActiveSheet.Pictures.Insert (RutaActual & "/CARPETAX/" & RangoImagen.Value & ".jpg")
ActiveCell.Offset(1, 0).Select
Loop

Range("B4").Select
On Error GoTo 0
Exit Sub

End If

End Sub



Avatar de Usuario
Gabriel Marq
Miembro Frecuente
Miembro Frecuente
Mensajes: 5
Registrado: 12 Oct 2019 12:13

Re: Completar macro para insertar imagen en celda...

Mensaje por Gabriel Marq » 17 Oct 2019 12:14

Código: Seleccionar todo

Option Explicit
'
'Arcan@ Master
'Version 8.5 Mar2018
'
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

	Dim CeldaActual As String
	Dim RutaActual As String
	Dim RangoImagen As Range
	Dim shp As Object

	CeldaActual = ActiveCell.Address
	RutaActual = ThisWorkbook.Path

	If Not Intersect(Target, Range("B1")) Is Nothing Then

		On Error Resume Next
		For Each shp In ActiveSheet.Shapes
			shp.Delete
		Next shp
		ActiveSheet.Range("E4").Select
		Do While ActiveCell.Offset(0, -1).Value <> Empty
			Set RangoImagen = ActiveCell.Offset(0, -1)
			ActiveSheet.Pictures.Insert (RutaActual & "/CARPETAX/" & RangoImagen.Value & ".jpg")
			ActiveCell.Offset(1, 0).Select
		Loop

		Range("B4").Select
		On Error GoTo 0
		Exit Sub

		End If

End Sub



Responder