Insertar imágenes en excel con vba

[Daniel-its]

Hola buen día
Tengo un problema que no he encontrado solución

Debo realizar un trabajo en el que debo insertar más de 500 imágenes y que estas queden ajustadas a las celdas
La imagen adjunta es solo un ejemplo, ya que no cuento con el documento original en mi pc

He estado leyendo varios sitios en inglés que te dan los códigos para insertarlos en visual basic, ya logré entender como se introducen los códigos. Pero no tengo idea de que modificar para que relacione el nombre de la celda, con el nombre de la imagen, y esta última la coloque en la celda deseada.

Este es el código que estoy usando.

► Mostrar Spoiler

Código: Seleccionar todo

Sub AddOlEObject()

Dim mainWorkBook As Workbook

Set mainWorkBook = ActiveWorkbook
Sheets("Object").Activate
Folderpath = "C:\Users\Sumit Jain\Pictures"
Set fso = CreateObject("Scripting.FileSystemObject")
NoOfFiles = fso.GetFolder(Folderpath).Files.Count
Set listfiles = fso.GetFolder(Folderpath).Files
For Each fls In listfiles
   strCompFilePath = Folderpath & "\" & Trim(fls.Name)
    If strCompFilePath <> "" Then
        If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
        Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
        Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
             counter = counter + 1
              Sheets("Object").Range("A" & counter).Value = fls.Name
              Sheets("Object").Range("B" & counter).ColumnWidth = 25
            Sheets("Object").Range("B" & counter).RowHeight = 100
            Sheets("Object").Range("B" & counter).Activate
            Call insert(strCompFilePath, counter)
            Sheets("Object").Activate
        End If
    End If
Next
mainWorkBook.Save
End Sub

Function insert(PicPath, counter)
'MsgBox PicPath
    With ActiveSheet.Pictures.insert(PicPath)
        With .ShapeRange
            .LockAspectRatio = msoTrue
            .Width = 50
            .Height = 70
        End With
        .Left = ActiveSheet.Range("B" & counter).Left
        .Top = ActiveSheet.Range("B" & counter).Top
        .Placement = 1
        .PrintObject = True
    End With
End Function

En este punto cualquier ayuda o sugerencia que me puedan brindar me viene bien.

De antemano muchas gracias.

[caher611]

Hola. Hace mucho tiempo que no programo en VB, pero intentaré explicarte un poco. Si has copiado el código literalmente lo primero que tienes que hacer es nombrar una hoja como "Object" o cambiar en las líneas donde se invoca Sheets el nombre por el que tengas en tu hoja. Para asociar los archivos tienes que cambiar la dirección en la línea Folderpath. Ahí tienes que poner la dirección completa donde tienes la carpeta con las imágenes. Según está ese código, te va a poner las imágenes en la columna B y los nombres de los archivos en la columna A. Saludos

[Daniel-its]

Gracias por la respuesta.
Realicé los cambios que me aconsejaste
Pero cuando trato de correr el código me marca el siguiente error y me señala la primer linea en amarillo
¿Qué estoy haciendo mal?

Aquí el código tal y como lo estoy usando en vba

► Mostrar Spoiler

Código: Seleccionar todo

Private Sub CommandButton1_Click()
Sub AddOlEObject()

Dim mainWorkBook As Workbook

Set mainWorkBook = ActiveWorkbook
Sheets("Object").Activate
Folderpath = "C:\Users\APC\Pictures\Saved Pictures\IMAGENES 1"
Set fso = CreateObject("Scripting.FileSystemObject")
NoOfFiles = fso.GetFolder(Folderpath).Files.Count
Set listfiles = fso.GetFolder(Folderpath).Files
For Each fls In listfiles
   strCompFilePath = Folderpath & "\" & Trim(fls.Name)
    If strCompFilePath <> "" Then
        If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
        Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
        Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
             counter = counter + 1
              Sheets("Object").Range("A" & counter).Value = fls.Name
              Sheets("Object").Range("B" & counter).ColumnWidth = 25
            Sheets("Object").Range("B" & counter).RowHeight = 100
            Sheets("Object").Range("B" & counter).Activate
            Call insert(strCompFilePath, counter)
            Sheets("Object").Activate
        End If
    End If
Next
mainWorkBook.Save
End Sub

Function insert(PicPath, counter)
'MsgBox PicPath
    With ActiveSheet.Pictures.insert(PicPath)
        With .ShapeRange
            .LockAspectRatio = msoTrue
            .Width = 50
            .Height = 70
        End With
        .Left = ActiveSheet.Range("B" & counter).Left
        .Top = ActiveSheet.Range("B" & counter).Top
        .Placement = 1
        .PrintObject = True
    End With
End Function

[Daniel-its]

Vale ya vi cual era mi error al introducir el código

► Mostrar Spoiler

Código: Seleccionar todo

Sub AddOlEObject()

Dim mainWorkBook As Workbook

Set mainWorkBook = ActiveWorkbook
Sheets("Object").Activate
Folderpath = "C:\Users\APC\Pictures\Saved Pictures\IMAGENES 1"
Set fso = CreateObject("Scripting.FileSystemObject")
NoOfFiles = fso.GetFolder(Folderpath).Files.Count
Set listfiles = fso.GetFolder(Folderpath).Files
For Each fls In listfiles
   strCompFilePath = Folderpath & "\" & Trim(fls.Name)
    If strCompFilePath <> "" Then
        If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
        Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
        Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
             counter = counter + 1
              Sheets("Object").Range("A" & counter).Value = fls.Name
              Sheets("Object").Range("B" & counter).ColumnWidth = 25
            Sheets("Object").Range("B" & counter).RowHeight = 100
            Sheets("Object").Range("B" & counter).Activate
            Call insert(strCompFilePath, counter)
            Sheets("Object").Activate
        End If
    End If
Next
mainWorkBook.Save
End Sub

Function insert(PicPath, counter)
'MsgBox PicPath
    With ActiveSheet.Pictures.insert(PicPath)
        With .ShapeRange
            .LockAspectRatio = msoTrue
            .Width = 50
            .Height = 70
        End With
        .Left = ActiveSheet.Range("B" & counter).Left
        .Top = ActiveSheet.Range("B" & counter).Top
        .Placement = 1
        .PrintObject = True
    End With
End Function

Ahora el problema es que cuando corro el código no hace lo que esperaba
Lo que hace es que me pega la imagen desde la celda "B1" y pega el nombre de la imagen en la columna "A1"
y así sucesivamente.

Los valores de la columna "A" están todos definidos y no cambian.
Lo que necesito es que inserte la imagen en la celda "B2, B3..." si coincide con el valor de la celda "A2, A3..."

Alguna idea?

[caher611]

No sé si te he entendido bien.¿Quieres que coincida el nombre con la imagen? Eso ya lo hace ahora.A mi entender lo mejor sería que pusiera las imágenes, por ejemplo, en unas 5 columnas y las filas hasta que terminen. Si no quieres que ponga el nombre en la columna A, pon una " ' " antes de la línea Sheets("Object").Range("A" & counter).Value = fls.Name.

[Daniel-its]

Gracias con ese cambio ya no reemplaza los nombres de la primera columna

Lamentablemente el formato que debo usar ya esta prediseñado y hay poco que puedo cambiar en cuanto al layout
Esta es una representación aproximada.

Viene a ser como un catalogo muy grande con al rededor de 400 números diferentes en la columna "A" y cada número tiene dos imágenes las cuales deben ir en su respectiva celda

Por lo cual el código tiene que poner la imagen "IMG001" en la columna "C4" solo si coincide que el valor de la celda "A4" es "IMG001"
Y así sucesivamente.

Esa es la razón por lo cual no puedo hacerlo manualmente. Ya que debería estar insertando una por una y ajustarlas manualmente a la celda.

Ya comprobé que el código funciona perfecto para insertar múltiples imágenes y ajustarlas a la celda. Solo necesito que las inserte en el orden que expliqué anteriormente.

Hay esperanza?

Muchas gracias por tu ayuda

[caher611]

Hola. Se puede hacer fácilmente lo que propones en la segunda imagen, pero antes me tienes que explicar por qué has nombrado a la función precisamente "AddOLEobject", desde dónde llamas a esa función para que se ejecute o si lo hace por ejemplo al abrirse el libro, activarse la hoja, etc...

[Daniel-its]

"AddOLEobject" Ya venía así en la página donde lo copié.

El código no lo usaría nadie mas que yo. Así que lo ejecuto directamente desde vba.
Al final los demás solo verán el trabajo impreso.

Por cierto encontré otro código que es un poco más intuitivo.
Pero por alguna razón no detecta las imágenes en la carpeta.

¿Qúe es lo que estoy haciendo mal?

► Mostrar Spoiler

Código: Seleccionar todo

Private Sub CommandButton1_Click()
Dim pictureNameColumn   As String 'column where picture name is found
Dim picturePasteColumn  As String 'column where picture is to be pasted

Dim pictureName         As String 'picture name
Dim lastPictureRow      As Long   'last row in use where picture names are
Dim pictureRow          As Long   'current picture row to be processed
Dim pathForPicture      As String 'path of pictures

pictureNameColumn = "A"
picturePasteColumn = "B"

pictureRow = 2 'starts from this row

'error handler
On Error GoTo Err_Handler

'find row of the last cell in use in the column where picture names are
lastPictureRow = Cells(Rows.Count, pictureNameColumn).End(xlUp).Row

'stop screen updates while macro is running
Application.ScreenUpdating = False

pathForPicture = "C:\Users\APC\Pictures\Saved Pictures\IMAGENES 1"
'loop till last row
Do While (pictureRow <= lastPictureRow)

pictureName = Cells(pictureRow, "A") 'This is the picture name

'if picture name is not blank then
If (pictureName <> vbNullString) Then

    'check if pic is present
    
    'Start If block with .JPG
    If (Dir(pathForPicture & pictureName & ".jpg") <> vbNullString) Then
        
        Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
        ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".jpg").Select 'Path to where pictures are stored
        
        With Selection
            .Left = Cells(pictureRow, picturePasteColumn).Left
            .Top = Cells(pictureRow, picturePasteColumn).Top
            .ShapeRange.LockAspectRatio = msoFalse
            .ShapeRange.Height = 100#
            .ShapeRange.Width = 130#
            .ShapeRange.Rotation = 0#
        End With
    'End If block with .JPG
    
    'Start ElseIf block with .PNG
    ElseIf (Dir(pathForPicture & pictureName & ".png") <> vbNullString) Then
        
        Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
        ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".png").Select 'Path to where pictures are stored
        
        With Selection
            .Left = Cells(pictureRow, picturePasteColumn).Left
            .Top = Cells(pictureRow, picturePasteColumn).Top
            .ShapeRange.LockAspectRatio = msoFalse
            .ShapeRange.Height = 100#
            .ShapeRange.Width = 130#
            .ShapeRange.Rotation = 0#
        End With
    'End ElseIf block with .PNG
    
    'Start ElseIf block with .BMP
    ElseIf (Dir(pathForPicture & pictureName & ".bmp") <> vbNullString) Then
        
        Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
        ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".bmp").Select 'Path to where pictures are stored
        
        With Selection
            .Left = Cells(pictureRow, picturePasteColumn).Left
            .Top = Cells(pictureRow, picturePasteColumn).Top
            .ShapeRange.LockAspectRatio = msoFalse
            .ShapeRange.Height = 100#
            .ShapeRange.Width = 130#
            .ShapeRange.Rotation = 0#
        End With
    'End ElseIf block with .BMP
    
    Else
        'picture name was there, but no such picture
        Cells(pictureRow, picturePasteColumn) = "No Picture Found"
    End If
    
Else
'picture name cell was blank
End If
'increment row count
pictureRow = pictureRow + 1
Loop

Exit_Sub:
Range("A10").Select
Application.ScreenUpdating = True
Exit Sub

Err_Handler:
MsgBox "Error encountered. " & Err.Description, vbCritical, "Error"
GoTo Exit_Sub

End Sub

[caher611]

Hola. Haz esto: En el primer código inserta la línea "counter=3" antes de la línea " For Each fls In listfiles...". Cambia el valor de Range en todas las líneas donde aparezca por la letra de la columna que prefieras (creo que en tu caso la C). Ahora copia el código entero y ponlo en un sitio diferente (módulo, procedimiento, etc..). Cambia la dirección de la carpeta de las imágenes que quieras poner y cambia el valor Range con la letra H. Si lo ejecutas directamente desde VB funcionará, aunque sería mejor llamar la función con un procedimiento, pero bueno creo que te servirá.

[Daniel-its]

Funcionó!

Muchas gracias por tu ayuda, sin duda me has salvado de horas de trabajo aburrido

Te debo Una!