指定したセルにフィットしたサイズで図を挿入（アドイン）

　ドラッグして選択した任意のセル範囲にフィットするサイズで、Excel に画像を挿入します。

　ドラッグして、画像を挿入する任意の大きさを設定する（理想は3：4）


　挿入する画像ファイルを選択する


　選択したセルの大きさにフィットしたサイズで画像が挿入されます




構文（ソース）はこちら
----

Sub 指定したセルに図を挿入()
    '----挿入する画像をダイアログで選択する
    sFilter = "全てのイメージ , *.bmp;*.jpg;*.gif;*.png;*.wmf"
    sFilter = sFilter & ",ビットマップ ファイル (*.bmp), *.bmp"
    sFilter = sFilter & ",jpg ファイル (*.jpg), *.jpg"
    sFilter = sFilter & ",gif ファイル (*.gif), *.gif"
    sFilter = sFilter & ",png ファイル (*.png), *.png"
    sFilter = sFilter & ",wmf ファイル (*.wmf), *.wmf"

    RetVal = Application.GetOpenFilename _
        (sFilter, 1, "挿入する画像を選択してください。", , False)
    If RetVal = False Or RetVal = "" Then Exit Sub
    '----
    MyLink = MsgBox("画像リンクを設定しますか？", vbYesNoCancel + vbInformation + vbMsgBoxSetForeground)
    Select Case MyLink
        Case vbYes, vbNo
        Case Else: Exit Sub
    End Select
    '----
    Application.ScreenUpdating = False '画面の動きを停止（フリーズ）する
    '----現在選択されているセルアドレスを変数に取り込む
    SelectedRange = ActiveWindow.Selection.Address
    Nr = Selection.Rows.Count
    Nc = Selection.Columns.Count
    Selection.Cells(1, 1).Select
    r1 = ActiveCell.Row
    r2 = r1 + Nr - 1
    c1 = ActiveCell.Column
    c2 = c1 + Nc - 1
    '----
    With ActiveSheet
        .Range(Cells(r1, c1), Cells(r2, c2)).Select
        RangeHeight = .Range(SelectedRange).Height
        RangeWidth = .Range(SelectedRange).Width
        RangeLeft = .Range(SelectedRange).Left
        RangeTop = .Range(SelectedRange).Top
    End With
    '----
    Select Case MyLink
        Case vbYes
            ActiveSheet.Pictures.Insert(RetVal).Select
        Case vbNo
            With ActiveSheet.Pictures.Insert(RetVal)
                .CopyPicture
                .Delete
            End With
            ActiveSheet.Paste
    End Select
    '----
    With Selection
        TrueSize = True
        HWRate = .Height / .Width '縦横比
        '----
        If .Height > RangeHeight Then
            TrueSize = False
            .Height = RangeHeight
            .Width = .Height / HWRate
        End If
        '----
        If .Width > RangeWidth Then
            TrueSize = False
            .Width = RangeWidth
            .Height = .Width * HWRate
        End If
        '----
        '+++++++++++++++++++++++++++++++++
        FitRate = 0.98 'フィット率：適宜変更
        '+++++++++++++++++++++++++++++++++
        If TrueSize = False Then
            .Width = .Width * FitRate
            .Height = .Height * FitRate
        End If
        '----画像を選択した範囲の中央に配置する
        .Left = RangeLeft + (RangeWidth - .Width) / 2
        .Top = RangeTop + (RangeHeight - .Height) / 2
    End With
    ActiveSheet.Range(Cells(r1, c1), Cells(r2, c2)).Select
    Application.ScreenUpdating = True '画面フリーズ解除
End Sub

----
※転載自由
※お好きなように編集してください。