Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。
100本ノックの出題リストはこちらから
excel-ubara.com
出題:セルに重なっている画像の削除
#VBA100本ノック 90本目
Rangeオブジェクトを引数で受け取り、そのセル範囲に少しでも重なっているいる画像を全て削除するFunctionを作成してください。
戻り値として削除した画像数を戻してください。
※あくまで画像です。
※画像の回転は考慮しない。垂直に置かれた画像だけを考えれば良い。

◇ 出題ページはこちら
ソースコード
メインモジュール
' 100本ノック090:セルに重なっている画像の削除 Function 指定セル範囲と重なる画像を削除する(対象セル範囲 As Range) As Long Dim ws対象シート As Worksheet: Set ws対象シート = 対象セル範囲.Worksheet ' シート内の全画像をループ Dim 削除数 As Long: 削除数 = 0 Dim シェイプ As Shape For Each シェイプ In ws対象シート.Shapes If シェイプ.Type = msoPicture Then ' シェイプを含む最小のセル範囲が引数のセル範囲と重なる部分を持てば画像を削除 If Not Intersect(対象セル範囲, GetRangeシェイプを含む最小のセル範囲(シェイプ)) Is Nothing Then シェイプ.Delete 削除数 = 削除数 + 1 End If End If Next 指定セル範囲と重なる画像を削除する = 削除数 End Function
汎用関数モジュール
' シェイプを含む最小のセル範囲 Function GetRangeシェイプを含む最小のセル範囲(対象シェイプ As Variant) As Range Dim 左上セル As Range Set 左上セル = 対象シェイプ.TopLeftCell Dim 右下セル As Range Set 右下セル = 対象シェイプ.BottomRightCell ' 図形が枠線に合わせて設置されている場合、 ' BottomRightCellが図形と重ならないセルを選択してしまう問題の調整 If Fx.Round(対象シェイプ.Top + 対象シェイプ.Height, 2) = Fx.Round(右下セル.Top, 2) Then Set 右下セル = 右下セル.Cells(0, 1) End If If Fx.Round(対象シェイプ.Left + 対象シェイプ.Width, 2) = Fx.Round(右下セル.Left, 2) Then Set 右下セル = 右下セル.Cells(1, 0) End If Set GetRangeシェイプを含む最小のセル範囲 = Range(左上セル, 右下セル) End Function
解説
処理自体は非常に単純なコードで、
- For Each で全シェイプをループ
- Type が Picture であるものを対象
- その画像を含む最小のセル範囲が指定範囲と重なれば画像を削除
というロジックを組んでいます。
この「画像を含む最小のセル範囲」については、
Shapeオブジェクトはシェイプと重なるセルのうち左上/右下を取得する、
TopLeftCell/BottomRightCellプロパティを持っています。
よってRange(TopLeftCell, BottomRightCell)とすることで簡単に取得できる。
はずだったんですが、残念ながらひとつだけ罠があり、
図形が枠線とぴったり(Altキーで配置した場合など)になっている場合は、
BottomRightCellが図形と重ならないセルを取ってきてしまう仕様があります。

この対策として、
- シェイプの左端からシェイプの幅を足した値がピッタリシェイプの右端
- シェイプの上端からシェイプの高さを足した値がピッタリシェイプの下端
になっている場合に、BottomRightCellを1つ調整しています。
この処理は小数の足し算のため、小数誤差が出ないよう四捨五入も忘れずに。
この手の面倒だけど本筋とはちょっとそれる処理(無関係な下位問題)は、
今回のコードのように別の関数として切り出すのが重要です。
メインロジック内でずらずらこのコードを書くと、
肝心のメインコードが読みづらくなってしまいますからね。
せっかくFunctionを題材にした問題ですので、
このFunctionのテクニックも併せて覚えてしまってください。