Excelのセル幅に合わせて縦横比を維持したまま画像サイズを自動調整する方法

VBAで画像を挿入することができますが、単純にセル幅に合わせて画像サイズを変更すると、縦長や横長の画像として挿入されます。
縦横比を維持したまま、画像を挿入する方法についてついて記載します。

VBAのマクロ機能を使用して画像サイズを調整する

ダブルクリックしたセルに画像を挿入するサンプルプログラムを記載します。
サンプルプログラムでは、ダブルクリックしたセルが結合セルの場合のみファイル選択画面を表示しています。

JPEG画像を貼り付ける場合にShapeRangeプロパティでは
幅と高さが正確に取得できない為、AddPictureで画像の幅と高さを調整しています。

サンプルプログラム

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    'セル選択判定
    '条件①結合セル②セル高さ100以上③セル幅100以上
    If Target.MergeCells And Target.Height >= 100 And Target.Width >= 100 Then

        Cancel = True

        '画像挿入
        Call PasteImage(Target)
    End If

End Sub


Option Explicit

Public Sub PasteImage(ByVal Target As Range)

    Dim fileNm As String
    Dim shp As Object
    Dim rng As Range
    Dim myRange As Range
    Dim pWidth As Single
    Dim pHeight As Single
    Dim pLeft As Single
    Dim pTop As Single
    Dim mWidth As Integer
    Dim mHeight As Integer
    Dim rX As Single
    Dim rY As Single
    Dim objShape As Shape

    '画像選択
    fileNm = Application.GetOpenFilename _
           ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
    If fileNm = "False" Then
        MsgBox "画像を選択してください"
        Exit Sub
    End If

    'セル内の画像削除
    For Each shp In ActiveSheet.Pictures
        Set rng = Range(shp.TopLeftCell, shp.BottomRightCell)

        If Not (Intersect(rng, Selection) Is Nothing) Then
            shp.Delete
        End If
    Next

    mWidth = 3  '左右余白
    mHeight = 3 '上下余白
    Set myRange = Target
    Application.ScreenUpdating = False

    '表示位置の取得
    With ActiveSheet.Pictures.Insert(fileNm).ShapeRange
        '左上隅の位置取得
        pLeft = .Left
        pTop = .Top
        '一旦画像を削除する
        .Delete
    End With

    '画像サイズの取得
    Set objShape = ActiveSheet.Shapes.AddPicture( _
        Filename:=fileNm, _
        LinkToFile:=False, _
        SaveWithDocument:=True, _
        Left:=0, _
        Top:=0, _
        Width:=0, _
        Height:=0)

    With objShape
        .LockAspectRatio = msoTrue
        .ScaleHeight 1, msoTrue
        .ScaleWidth 1, msoTrue

        '画像サイズをセルの幅、高さに合わせる
        rX = myRange.Width / .Width
        rY = myRange.Height / .Height

        If rX > rY Then
            .Height = .Height * rY - mHeight
            .Width = .Width - mWidth
        Else
            .Height = .Height - mHeight
            .Width = .Width * rX - mWidth
        End If
        pWidth = .Width
        pHeight = .Height

        '表示位置をセルの幅、高さに合わせる
        pLeft = pLeft + (myRange.Width - .Width) / 2
        pTop = pTop + (myRange.Height - .Height) / 2
        '一旦画像を削除する
        .Delete
     End With

    '画像の貼り付け
    Set objShape = ActiveSheet.Shapes.AddPicture( _
        Filename:=fileNm, _
        LinkToFile:=False, _
        SaveWithDocument:=True, _
        Left:=pLeft, _
        Top:=pTop, _
        Width:=pWidth, _
        Height:=pHeight)

    Application.ScreenUpdating = True

End Sub