Excelに貼り付けた画像を全て同じサイズに変更するVBA

あらすじ

Excelにスクリーンショットや画像を貼って、

それらを全て同じサイズにトリミングすることがあります。

１つずつ画像をトリミングしていくのはとても時間が勿体無いし、

微妙に誤差がでるので、VBAを使って綺麗に統一することにしました。

　

　

TL;DR¹

同じサイズの画像が貼られたExcelシートを用意する

シートにVBAを貼り付けて調整する

実行するとシート内の全画像が同じサイズに削られる

　

　

前提条件

• シート内にある画像が全て同じサイズであること
• VBAコードはシート単位に処理するため適宜コードをペーストして実行すること
• コードを実行するとundoできない（元に戻せない）ためバックアップファイルを用意すること

　

　

実施手順

Excelにスクリーンショット等の画像を貼り付け

Excelシートに画像を貼り付けます。

　

　

VBAのコードを貼り付ける画面に移動

画像が貼られているシートを右クリックして「コードを表示」を選択します。

　

赤枠部分がコード入力欄になります。

　

　

VBAコードを貼り付ける

下記のコードをコード入力欄に貼り付けます。

Sub main()
    Const CutTop As Double = 0 '上の切り取り
    Const CutLeft As Double = 0 '左の切り取り
    Const CutBottom As Double = 300 '下の切り取り
    Const CutRight As Double = 200 '右の切り取り
    Dim ws As Worksheet
    Dim sp1 As Shape
    Set ws = ActiveSheet
    
    Dim i As Integer
    i = 1
    
    For i = 1 To ws.Shapes.Count
        Set sp1 = ws.Shapes(i)
        With sp1
            .PictureFormat.CropTop = CutTop
            .PictureFormat.CropLeft = CutLeft
            .PictureFormat.CropBottom = CutBottom
            .PictureFormat.CropRight = CutRight
        End With
    Next
    
End Sub

　

　

コードの説明

重要なのは以下の部分

Const OffTop As Double = 0 '上の切り取り
Const OffLeft As Double = 0 '左の切り取り
Const OffBottom As Double = 300 '下の切り取り
Const OffRight As Double = 200 '右の切り取り

画像の上下左右端からそれぞれどれぐらいの幅を削除するかという内容になってます。

上記コードの例を説明すると、

下部分（Bottom）を300、右部分（Right)を200ほど切り取るという内容になります。

　

数値は最初は小さい値で実行し、

徐々に大きい値に変更して実行するのが良いです。

　

コードを実行する

F5キーまたはメニューバーから実行することで動きます。

　

　

　

よいVBAライフを～

以上