【EXCEL マクロ】写真のサイズを自動調整して貼り付ける

EXCELに写真を貼り付ける事多いですね。
写真をセルのサイズに自動調整して貼り付ける方法を紹介します。

写真のサイズを自動調整して貼り付ける

まずは結果をご覧ください。

全て同じ写真を異なるサイズのセルに挿入した結果です。
やりたかった事は
１．写真を挿入したいセルをダブルクリック
２．写真ファイルを選択
３．セルのサイズに自動調整した写真が挿入される
です。

VBAを紹介

VBAの始め方

VBAをやった事がない方はこちらをご覧ください。
【EXCELで仕事の効率化】EXCEL VBAの始め方＆保存方法
始め方から保存方法まで紹介しています。

VBA紹介

こちらのVBAは
ThisWorkbook
に記載して下さい。

こちらをコピー＆ペーストして下さい。
楽ちんです♪

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim A As Variant
Dim ASS As Object
Dim I As String
Dim J As String
Cancel = True

A = Application.GetOpenFilename _
("画像ファイル,*.jpg;*.png", , "画像ファイルを選択して下さい", , False)

If A = False Then
    Exit Sub
End If

For Each ASS In ActiveSheet.Shapes
    I = ASS.TopLeftCell.MergeArea.Address
    J = Target.Address
    If I = J Then ASS.Delete
Next

Set ASS = ActiveSheet.Shapes.AddPicture(Filename:=A, LinkToFile:=False, _
SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _
Width:=0, Height:=0)
ASS.ScaleHeight 1, msoTrue
ASS.ScaleWidth 1, msoTrue
ASS.LockAspectRatio = msoTrue

If ASS.Height / Target.Height > ASS.Width / Target.Width Then
    ASS.Height = Target.Height
Else
    ASS.Width = Target.Width
End If

ASS.Left = Target.Left + (Target.Width - ASS.Width) / 2
ASS.Top = Target.Top + (Target.Height - ASS.Height) / 2

Set ASS = Nothing
End Sub

当VBAはこちらを参考にさせて頂きました。

実行してみる

実行方法は画像を挿入したいセルをダブルクリック。
画像を選択するウィンドウが開きます。

ファイルを選択して「開く」するだけです。
いろんなサイズのセルに画像挿入した結果です。

結合したセルにも対応しています。

まとめ

報告書など作成する時などにおすすめです。
写真貼り付け後にセルサイズ変更した場合は追従しません。
写真を一旦削除して再度実行してください。

当ブログのトップページはこちらです。
ブックマークして頂けると嬉しいです。
よろしくお願いいたします。