このサイトの記事内では「アフィリエイト広告」などの広告を掲載している場合があります。
消費者庁が問題としている「誇大な宣伝や表現」とならないよう配慮しコンテンツを制作しておりますのでご安心ください。
問題のある表現が見つかりましたらお問い合わせよりご一報いただけますと幸いです。

【VBA】画像ファイルをセル範囲に合わせて拡大縮小するマクロ

2021年9月30日

あ~画像サイズ調整するのクソだるい~
誰か代わりにやってくれー!

カチカチカチカチカチカチカチ…

資料作る時とかに画像のサイズ調整するのって面倒ですよね。

そんなあなたに朗報です
画像サイズを一発で変更するマクロを紹介します

画像サイズはExcelのセル範囲に合わせて、自動で拡大縮小するのでカチカチする必要はありません!

このマクロを使って不毛な作業から解放されちゃいましょう!

VBAが難しいと感じたら
VBAのプロに代わりに作ってもらうのはいかがでしょうか?
ココナラでVBAの作成請負を受け付けています。お気軽にご相談ください。

画像ファイルをセル範囲に合わせて拡大縮小するマクロ

どんなことができるのか?

まず貼付けしたい範囲を選択して、マクロを実行します。

ファイル選択ダイアログが開くので、画像ファイルを選択します。

すると、画像ファイルが選択した範囲に合わせたサイズで貼付けされます。
※貼付けされるのは選択範囲のど真ん中で、余白調整も可能です。

ソースコード

Sub ImportPicSelection()
'外部から画像ファイルをインポートし、選択範囲のサイズに合わせて貼付ける

    Const MARGIN = 0.95 '余白調整用
    
    'セル以外を選択している場合はExit
    If Not TypeName(Selection) = "Range" Then Exit Sub
    
    '画像ファイルの選択
    Dim filePath As String
    filePath = Application.GetOpenFilename( _
        filefilter:="Pictures (*.png; *.gif; *.jpg; *.bmp; *.tif),*.png; *.gif; *.jpg; *.bmp; *.tif", _
        Title:="画像選択ダイアログ", _
        MultiSelect:=False)
    
    '画像選択されない場合はExit
    If filePath = "False" Then Exit Sub
    
    '画像ファイルの取込み
    With ActiveSheet.Shapes.AddPicture( _
        Filename:=filePath, _
        linktofile:=False, _
        savewithdocument:=True, _
        Left:=Selection.Left, _
        Top:=Selection.Top, _
        Width:=0, _
        Height:=0)
        
        '一旦元のサイズに戻す
        .ScaleHeight 1, msoTrue
        .ScaleWidth 1, msoTrue
        
        'サイズ調整(Selection内に収める)
        Dim dblScal As Double
        If Selection.Width / .Width < Selection.Height / .Height Then
            dblScal = WorksheetFunction.RoundDown(Selection.Width / .Width, 2) * MARGIN
        Else
            dblScal = WorksheetFunction.RoundDown(Selection.Height / .Height, 2) * MARGIN
        End If
        .ScaleHeight dblScal, msoFalse
        .ScaleWidth dblScal, msoFalse
        
        'Selectionの中心に配置
        .Left = .Left + (Selection.Width - .Width) / 2
        .Top = .Top + (Selection.Height - .Height) / 2
        
    End With
End Sub

AddPictureというメソッドで画像の取り込みをしています。
取り込んだ画像ファイルに対して、セル範囲に合わせて拡大(縮小)率を計算して選択範囲内に収めています。

そして、一番最後に選択範囲の中心に来るように移動させています。

余白はMARGINという定数を変更することで調整できるように作っています。
今は0.95としていますが、必要に応じて変更してみてください。

VBAが難しいと感じたら
VBAのプロに代わりに作ってもらうのはいかがでしょうか?
ココナラでVBAの作成請負を受け付けています。お気軽にご相談ください。

VBA

Posted by やろまい