ダブルクリックでセルに画像を貼りつける（Pictures.Insertメソッド）｜Excel VBA

ツイート

［ファイルを開く］ダイアログボックスで指定した画像をセルに貼りつけます。
画像が縦長の場合は縦方向をセル高いっぱい、横方向をセルの中央に配置し、画像が横長の場合は縦方向をセルの中央、横方向をセル幅いっぱいに配置します。

セルをダブルクリックしたときに貼りつけるには、対象シートのシートモジュールにBeforeDoubleClickイベントのイベントプロシージャを記述します。ただし、このイベントプロシージャを記述したワークシートでのみ有効となります。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
                                        Cancel As Boolean)
    Dim PicFile As Variant
    Dim rX As Double, rY As Double

    '［ファイルを開く］ダイアログボックスを表示
    PicFile = Application.GetOpenFilename( _
                        "画像ファイル,*.jpg;*.jpeg;*.gif;*.tif;*.png;*.bmp")
    If VarType(PicFile) = vbBoolean Then Cancel = True: Exit Sub


    Application.ScreenUpdating = False
    
    '画像を挿入
    With ActiveSheet.Pictures.Insert(PicFile)
        rX = Target.Width / .Width
        rY = Target.Height / .Height
        If rX > rY Then
            .Height = .Height * rY
        Else
            .Width = .Width * rX
        End If

        'セルの中央（横方向/縦方向の中央）に配置
        .Left = Target.Left + (Target.Width - .Width) / 2
        .Top = Target.Top + (Target.Height - .Height) / 2
    End With
    
    Application.ScreenUpdating = True
    Cancel = True
End Sub