Skill Note

平凡なエンジニアがメモ代わりにプログラミング, インフラ, ネットワークを書き綴るブログ

Excelのセル幅に合わせて縦横比を維持したまま画像サイズを自動調整する方法

      2019/12/20

VBAで画像を挿入することができますが、単純にセル幅に合わせて画像サイズを変更すると、縦長や横長の画像として挿入されます。
縦横比を維持したまま、画像を挿入する方法についてついて記載します。

VBAのマクロ機能を使用して画像サイズを調整する

ダブルクリックしたセルに画像を挿入するサンプルプログラムを記載します。
サンプルプログラムでは、ダブルクリックしたセルが結合セルの場合のみファイル選択画面を表示しています。

JPEG画像を貼り付ける場合にShapeRangeプロパティでは
幅と高さが正確に取得できない為、AddPictureで画像の幅と高さを調整しています。

サンプルプログラム

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    'セル選択判定
    '条件①結合セル②セル高さ100以上③セル幅100以上
    If Target.MergeCells And Target.Height >= 100 And Target.Width >= 100 Then

        Cancel = True

        '画像挿入
        Call PasteImage(Target)
    End If

End Sub


Option Explicit

Public Sub PasteImage(ByVal Target As Range)

    Dim fileNm As String
    Dim shp As Object
    Dim rng As Range
    Dim myRange As Range
    Dim pWidth As Single
    Dim pHeight As Single
    Dim pLeft As Single
    Dim pTop As Single
    Dim mWidth As Integer
    Dim mHeight As Integer
    Dim rX As Single
    Dim rY As Single
    Dim objShape As Shape

    '画像選択
    fileNm = Application.GetOpenFilename _
           ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
    If fileNm = "False" Then
        MsgBox "画像を選択してください"
        Exit Sub
    End If

    'セル内の画像削除
    For Each shp In ActiveSheet.Pictures
        Set rng = Range(shp.TopLeftCell, shp.BottomRightCell)

        If Not (Intersect(rng, Selection) Is Nothing) Then
            shp.Delete
        End If
    Next

    mWidth = 3  '左右余白
    mHeight = 3 '上下余白
    Set myRange = Target
    Application.ScreenUpdating = False

    '表示位置の取得
    With ActiveSheet.Pictures.Insert(fileNm).ShapeRange
        '左上隅の位置取得
        pLeft = .Left
        pTop = .Top
        '一旦画像を削除する
        .Delete
    End With

    '画像サイズの取得
    Set objShape = ActiveSheet.Shapes.AddPicture( _
        Filename:=fileNm, _
        LinkToFile:=False, _
        SaveWithDocument:=True, _
        Left:=0, _
        Top:=0, _
        Width:=0, _
        Height:=0)

    With objShape
        .LockAspectRatio = msoTrue
        .ScaleHeight 1, msoTrue
        .ScaleWidth 1, msoTrue

        '画像サイズをセルの幅、高さに合わせる
        rX = myRange.Width / .Width
        rY = myRange.Height / .Height

        If rX > rY Then
            .Height = .Height * rY - mHeight
            .Width = .Width - mWidth
        Else
            .Height = .Height - mHeight
            .Width = .Width * rX - mWidth
        End If
        pWidth = .Width
        pHeight = .Height

        '表示位置をセルの幅、高さに合わせる
        pLeft = pLeft + (myRange.Width - .Width) / 2
        pTop = pTop + (myRange.Height - .Height) / 2
        '一旦画像を削除する
        .Delete
     End With

    '画像の貼り付け
    Set objShape = ActiveSheet.Shapes.AddPicture( _
        Filename:=fileNm, _
        LinkToFile:=False, _
        SaveWithDocument:=True, _
        Left:=pLeft, _
        Top:=pTop, _
        Width:=pWidth, _
        Height:=pHeight)

    Application.ScreenUpdating = True

End Sub

Google AdSense PC

Google AdSense PC

Message

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です

  関連記事

microsoft
[Windows]Active ReportsでPDF出力時の注意事項

PDF出力時の「LicenseException」対応方法 環境 ActiveReports for .NET 7.0J 言語:C# 設定 Active Rep …

microsoft
Windows標準機能を使ってフォルダの作成を自動化する方法

バッチファイルとタスクスケジューラでフォルダの作成を自動化する方法を記載します。 この記事の例では、毎月1日になると指定した場所に年月のフォルダを作成します。 …

microsoft
VBAで指定フォルダ内の全てのExcelファイル・シートを順番に開く方法

この記事では、VBAで指定フォルダ内の全てのExcelファイル・シートを順番に開く方法について記載します。 指定フォルダの選択は、ダイアログを表示して任意の場所 …

microsoft
VBAからOracleに接続する方法(Oracle Provider for OLE DB接続)

VBAから業務システムなどに使用しているデータベースに接続し、データを抽出することができます。 定期的に作成する資料などは、VBAでデータ取得処理を自動化し、ボ …

microsoft
【パソコン不要】HDDのデータをSSDに丸ごとコピーして交換する方法

近頃はSSDの記憶容量の増加、価格の値下がりが続き、HDDとの容量・価格差も縮まり購入しやすい状況となっています。HDDからSSDに交換することで読込・書込速度 …

Excelファイルの更新をメールで自動通知する方法【業務自動化】

ファイルを複数人で共有している時など、更新時にメンバーへ連絡することがルール化されている場合があります。 毎回、口頭や手動でメールで連絡していると、連絡漏れや連 …

microsoft
VBAでひらがな・カタカナの小文字(捨て仮名)を全角に変換する

VBAで半角文字から全角文字に変換したり、ひらがなをカタカナに変換するには、「StrConv」関数に引数を指定することで意図した文字に変換することができます。た …

microsoft
VBAで形式を指定して日付を取得する

VBAで西暦や和暦の日付形式に変換するには「FORMAT」関数に引数を指定することで意図した日付形式に変換することができます。 日付を表示 Date関数で今日の …

microsoft
エクセルで円と銭の通貨単位を表示する

Excelで入力した数値に円と銭の単位を表示する方法を記載します。 2種類の表示方法がありますので、用途に応じて使い分けてください。 セルの書式設定で表示 セル …

microsoft
[Windows]Windows Server 2008 R2 IISインストール手順

Windows Server 2008 R2にIISをインストールする 環境 OS:Windows Server 2008 R2 IIS:ver7.5 インスト …