Excel VBA: Transferring user-selected images from a userform to a worksheet with conserved aspect ratio and responsive fit

Question

I am creating a userform in Excel using VBA that accepts user-selected images. When the user submits the form with a chosen image, the userform is meant to put the image into column A of the connected worksheet, so that the aspect ratio of the image is maintained and the image and cell fit together, like a picture and picture frame.

I tried the below code:

Dim EmptyRow As Long

'Make the Appointments worksheet active
Worksheets("Appointments").Activate

'Determine the empty row
EmptyRow = WorksheetFunction.CountA(Range("B:B")) + 1

'Insert and format photo
Set photo = ActiveSheet.Pictures.Insert(ImagePath)
With photo

    .Left = ActiveSheet.Cells(EmptyRow, 1).Left
    .Top = ActiveSheet.Cells(EmptyRow, 1).Top
    
    With .ShapeRange
        .LockAspectRatio = msoTrue
        .Width = ActiveSheet.Columns("A").ColumnWidth
    End With
    
    'Set the format of the picture cell
    ActiveSheet.Rows(EmptyRow).RowHeight = photo.ShapeRange.Height
    
    .Placement = 1
    
End With

At insertion, image width is not set to the width of the cell they are in. When adjusting image/cell dimensions, image aspect ratio isn't maintained and image/cell width/height does not change to fit the cell/image.

At insertion, I was expecting the cell containing the image to act as a picture frame for the image. In other words, I was expecting

1. the image's aspect ratio to be conserved,
2. the image width to equal the width of the column containing it,
3. and the height of the row containing it to equal the image height.

Upon changing image/cell dimensions, I was expecting the dimensions of the cell/image to change such that

1. the image's/cell's aspect ratio to be maintained,
2. and the dimensions of the image/cell to fit with the change.

Edit: With taller_ExcelHome's suggestion, the inserted image now has preserved aspect ratio. It equates its width to the width of the picture column, lengthens its height according to its aspect ratio, and equates the height of the row containing it to the image's height. Widening the picture column also widens the image correctly. However, it break the aspect ratio of the image instead of lengthening the height of the image and row accordingly:

Answer 1

Your code is almost complete. The only change needed is

    With .ShapeRange
        .LockAspectRatio = msoTrue
        .Width = Cells(EmptyRow, 1).Width
    End With

One unit of column width is equal to the width of one character in the Normal style.

Range.Widthreturns a Double value that represents the width of a range in points.

Please refers to Microsoft document.

Range.ColumnWidth property (Excel)

Range.Width property (Excel)

---

Question: Is there no way to fix the image aspect ratio if the column width or row height is manually changed?

Answer: The provided code auto-fit image with column width and extend row height as needed. (similar logic as your OP)

Sub AutoFitImage()
    Dim s As Shape
    For Each s In ActiveSheet.Shapes
        s.LockAspectRatio = msoFalse
        s.Placement = xlFreeFloating
        s.ScaleWidth 1, msoTrue
        s.ScaleHeight 1, msoTrue
        s.LockAspectRatio = msoTrue
        With s.TopLeftCell
            s.Top = .Top
            s.Left = .Left
            s.Width = .Width
            .EntireRow.RowHeight = s.Height
        End With
        s.Placement = xlMoveAndSize
    Next
End Sub

If you prefer to shrink image to autofit a cell, please refers to

In Excel, can a button be created to insert photos into cells without distorting the original image aspect ratio?