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
'----
※転載自由
※自由に編集してください。