Insertar imágenes en Excel y ajustar tamaño a celdas con macros vba

En este artículo y video retomamos un tema que tocamos hace algunos meses, y es el tema de Insertar imágenes en Excel usando macros vba. En aquella ocasión contábamos con una carpeta donde teníamos algunas imágenes y esas imágenes se insertaban en un archivo de Excel.

Sin embargo en aquella macro nos faltó incluir una manera de que las imágenes puedan adecuarse al tamaño de una celda.

Comentarios de YouTube

Leyendo los comentarios de aquél video, me di cuenta que varias personas me preguntaban acerca de que las imágenes insertadas se ajusten al tamaño de una celda. Le daremos especial atención al comentario de Yony García, en el cual nos presenta un código vba que adecuó a nuestra macro. Tal código sirve para darle un tamaño específico a una imagen seleccionada.

Figura 1. Comentario en YouTube donde un usuario nos comparte una macro para ajustar tamaño a imágenes.

Video Insertar imágenes en Excel y ajustar a celdas

Suscríbete al canal de EXCELeINFO en YouTube para aprender más de Excel y macros.

Ajustar imágenes a tamaño de celdas conservando su aspecto

En el sitio ExtendedOffice nos encontramos con una macro que nos ayudará a ajustar el tamaño de una imagen seleccionada al tamaño de una celda de Excel, sin embargo el tamaño se ajusta conservando la relación de aspecto, es decir, cambiamos el tamaño sin perder la apariencia.

Las imágenes se encuentran en una carpeta llamada Coches y tienen un tamaño ligeramente diferente.

Figura 2. Imágenes a insertar en Excel.

Al correr la macro, se insertarán las imágenes en cada celda y posteriormente se ajustarán el tamaño, respetando la relación de aspecto.

Figura 3. Se insertarán las imágenes respetando la relación de aspecto.

Macro para ajustar tamaño de imágenes respetando relación de aspecto

Public Sub FitPic()
'https://www.extendoffice.com/documents/excel/1060-excel-resize-picture-to-fit-cell.html
    On Error GoTo NOT_SHAPE
    Dim PicWtoHRatio As Single
    Dim CellWtoHRatio As Single
    With Selection
        PicWtoHRatio = .Width / .Height
    End With
    With Selection.TopLeftCell
        CellWtoHRatio = .Width / .RowHeight
    End With
    Select Case PicWtoHRatio / CellWtoHRatio
    Case Is > 1
        With Selection
            .Width = .TopLeftCell.Width
            .Height = .Width / PicWtoHRatio
        End With
    Case Else
        With Selection
            .Height = .TopLeftCell.RowHeight
            .Width = .Height * PicWtoHRatio
        End With
    End Select
    With Selection
        .Top = .TopLeftCell.Top
        .Left = .TopLeftCell.Left
    End With
    Exit Sub
NOT_SHAPE:
    MsgBox "Select a picture before running this macro."
End Sub

Ajustar imágenes a un tamaño definido

Retomando el comentario del usuario en YouTube, nos compartió una macro para ajustar el tamaño a las imágenes a un alto y un ancho que definimos manualmente. Agradezco de sobremanera su comentario.

Figura 4. Se insertarán las imágenes con un tamaño definido manualmente.

Macro para definir un alto y un ancho a las imágenes

La ventaja de la siguiente macro es que podemos definirle un alto y un ancho manual a las imágenes, sólo recomiendo no dar números hagan que el aspecto de las imágenes se pierda.

Sub FitPic_2()
    With Selection
        .ShapeRange.LockAspectRatio = msoFalse
        .ShapeRange.Height = 100
        .ShapeRange.Width = 100
    End With
End Sub

Macro para insertar imágenes

La siguiente macro es la que nos sirve para insertar las imágenes. Se podrá combinar con cualquiera de las dos macros anteriores.

Option Explicit

'EXCELeINFO
'MVP Sergio Alejandro Campos
'http://www.exceleinfo.com
'https://www.youtube.com/user/sergioacamposh

Sub InsertarImagenes_2()
    
    'Declaramos variables
    Dim RutaActual As String
    Dim RangoImagen As Range
    Dim shp As Object
    
    'En caso de error...
    'On Error GoTo ManejadorErrores
    On Error Resume Next
    
    For Each shp In ActiveSheet.Shapes
        If shp.Name = "imagen2" Then
        Else
            shp.Delete
        End If
    Next
    
    'La variable RutaActual guardará la ruta completa donde está el archivo
    RutaActual = ThisWorkbook.Path
    
    'Desactivamos la actualización de pantalla
    Application.ScreenUpdating = False
    
    'Elegimos la celda B3
    ActiveSheet.Range("B3").Select
    
    'Recorremos cada fila mientras haya datos en la columna A
    Do While ActiveCell.Offset(0, -1).Value <> Empty
        
        Set RangoImagen = ActiveCell.Offset(0, -1)
        
        'Insertamos la imagen que corresponda al nombre de la columna A
        ActiveSheet.Pictures.Insert(RutaActual & "\Coches\" & RangoImagen.Value & ".jpg").Select
        'Ajustar tamaño a imágenes respetando relación de aspecto
        'Call FitPic
        'Ajustar tamaño a imágenes definiendo un alto y un ancho
        'Call FitPic_2
        
        'Activamos la siguiente fila
        ActiveCell.Offset(1, 0).Select
        
    Loop
    
    Range("A2").Select
    Application.ScreenUpdating = True
    
    On Error GoTo 0
    
End Sub

Descargar el archivo de ejemplo

 Insertar imágenes en Excel – 2 – EXCELeINFO.zip