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

EXCEL

2024.04.06 2022.12.11

本ページはプロモーションが含まれています

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

写真のサイズを自動調整して貼り付ける
VBAを紹介
1. VBAの始め方
2. VBA紹介
実行してみる
まとめ

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

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

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

VBAを紹介

VBAの始め方

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

VBA紹介

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

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

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

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はこちらを参考にさせて頂きました。

Excelの魔術師へ！さいしょの一歩