VBA100本ノック 90本目：セルに重なっている画像の削除

公開日：2021-02-17　最終更新日：2021-02-22

VBA100本ノック 90本目：セルに重なっている画像の削除

セル範囲に少しでも重なっているいる画像を全て削除するFunctionを作成する問題です。

ツイッター連動企画です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。

VBAテスト用のサンプルデータは、VBA100本ノックの目次ページ からもダウンロードできます。

マクロVBAを初心者向けの基本から上級者向けの高度な内容までサンプルコードを掲載し解説しています。エクセル関数・機能・基本操作の入門解説からマクロVBAまでエクセル全般を網羅しています。

出題

#VBA100本ノック 90本目
Rangeオブジェクトを引数で受け取り、そのセル範囲に少しでも重なっているいる画像を全て削除するFunctionを作成してください。
戻り値として削除した画像数を戻してください。
※あくまで画像です。
※画像の回転は考慮しない。垂直に置かれた画像だけを考えれば良い。

サンプルファイルです。
https://excel-ubara.com/vba100sample/VBA100_90.xlsm
https://excel-ubara.com/vba100sample/VBA100_90.zip

VBA作成タイム

この下に頂いた回答へのリンクと解説を掲載しています。
途中まででも良いので、できるだけ自分でVBAを書いてみましょう。

他の人の回答および解説を見て、書いたVBAを見直してみましょう。

頂いた回答

出題ツイートの引用ツイートでの回答

解説

まずポイント解説から。
・RangeオブジェクトにはAreasがあるのでAreasが複数の場合を考慮するか
・ShapesとPicturesのどちらを使うか
・TopLeftCellとBottomRightCellを使うか
・Top,Left,Height,Widthだけでやるか
このあたりでVBAが変わってきます。
まずは共通部分から。


  
    
      Option Explicit


      '四隅の位置：Top,Left,Height,Widthだけで判定する時に使う

Type tRect

　　Top As Double

　　Left As Double

　　Bottom As Double

　　Right As Double

End Type


'テストメイン

Sub main()

　　ActiveSheet.Copy after:=ActiveSheet

　　Debug.Print VBA100_90(ActiveSheet.Range("B5,F3:F4"))

End Sub


'メイン関数

Function VBA100_90(ByVal aRng As Range) As Long

　　Dim cnt As Long, rng As Range

　　For Each rng In aRng.Areas

　　　　cnt = cnt + VBA100_90_01(rng)

'　　　　cnt = cnt + VBA100_90_02(rng)

　　Next

　　VBA100_90 = cnt

End Function


'共通関数：小数2桁に四捨五入

      Function wsfRound(ByVal arg As Double, ByVal num As Long) As Double

　　wsfRound = WorksheetFunction.Round(arg, num)

End Function

Areasの処理はFor EachでRange.Areasを処理すれば良いです。
Shapesには全て入っているのでShapesでも構いませんが、その後にPictureに絞るなら最初からPicturesの方が手っ取り早いかもしれません。
TopLeftCellとBottomRightCellを使ってIntersectする場合はBottomRightCellが要注意です。


  
    
      'TopLeftCellとBottomRightCellを使ってIntersect

Function VBA100_90_01(ByVal aRng As Range) As Long

　　VBA100_90_01 = 0

　　

　　Dim pic As Picture, tlRng As Range, brRng As Range

　　For Each pic In aRng.Parent.Pictures

　　　　Set tlRng = pic.TopLeftCell

　　　　Set brRng = pic.BottomRightCell

　　　　

      　　　　'BottomRightCellはAltキーで境界に配置した場合にずれる

      　　　　If wsfRound(pic.Top + pic.Height, 2) <= brRng.Top Then

　　　　　　Set brRng = brRng.Offset(-1)

　　　　End If

      　　　　If wsfRound(pic.Left + pic.Width, 2) <=brRng.Left Then

　　　　　　Set brRng = brRng.Offset(, -1)

　　　　End If

　　　　

　　　　If Not Intersect(aRng, Application.Range(tlRng, brRng)) Is Nothing Then

　　　　　　pic.Delete

　　　　　　VBA100_90_01 = VBA100_90_01 + 1

　　　　End If

　　Next

End Function

Top,Left,Height,Widthだけで判定する場合は、四辺の位置を判定しなければならないので、IF文が複雑になりがちです。
構造体を使い、かつ、フラグを使ってみました。
このあたりは、記述方法だけなので色々な書き方が出来ると思います。


  
    
      'Top,Left,Height,Widthだけで判定

Function VBA100_90_02(ByVal aRng As Range) As Long

　　VBA100_90_02 = 0


　　Dim rngRect As tRect, picRect As tRect

　　Dim pic As Picture, isDel As Boolean


　　Dim sp As Shape

　　rngRect = getRect(aRng.Top, aRng.Left, aRng.Height, aRng.Width)

　　For Each pic In aRng.Parent.Pictures

　　　　isDel = True

　　　　picRect = getRect(pic.Top, pic.Left, pic.Height, pic.Width)

　　　　If picRect.Top >= rngRect.Bottom Then isDel = False

　　　　If picRect.Left >= rngRect.Right Then isDel = False

　　　　If picRect.Bottom <= rngRect.Top Then isDel = False

　　　　If picRect.Right <= rngRect.Left Then isDel = False

　　　　If isDel Then

　　　　　　pic.Delete

　　　　　　VBA100_90_02 = VBA100_90_02 + 1

　　　　End If

　　Next

End Function


'If判定の記述を簡易にするために構造体を使用

Function getRect(ByVal aTop As Double, ByVal aLeft As Variant, ByVal aHeight As Double, ByVal aWidth As Double) As tRect

　　getRect.Top = wsfRound(aTop, 2)

　　getRect.Left = wsfRound(aLeft, 2)

　　getRect.Bottom = wsfRound(aTop + aHeight, 2)

　　getRect.Right = wsfRound(aLeft + aWidth, 2)

End Function

PictureのTopやLeftの数値が小数誤差を起こす場合があります。
特に125%(120DPI)では発生頻度高そうです。
そのままでは位置判定が狂ってしまうので、wsfRoundで小数2桁に四捨五入して誤差を補正しています。
記事補足に追加説明を記載しました。

補足

BottomRightCellの注意点

最初の動画のように、Altキーを使って境界に配置します。
この場合のBottomRightCellは、境界方向に1セルずれたセルが返ってきます。
したがって、画像の下端または右端とBottomRightCellのTopまたはLeftと比較してOffsetする必要があります。

TopやLeftの数値誤差の発生

画像はB2セルの左上にぴってりくっつけて配置しています。

Topで小数誤差?が発生しています。
ただし、96DPIでは次の120DPIに比べて発生頻度は低いようです。

また、ShapesとPicturesでも数値が違っていたりするのでかなり厄介です。

125%(120DPI)では小数誤差?がかなりの確率で発生しています。
Topだけの場合もあれば、Leftだけの場合もあります。
この誤差は、本来の数値より大きくなる場合もあれば小さくなる場合もあります。

ShapesとPictureでは数値に差異があります

※以上を踏まえて、先のVBAでは小数2桁で四捨五入して使っています。

サイト内関連ページ

100本ノック 29本目：画像の挿入

・出題・頂いた回答・解説・補足・サイト内関連ページ

100本ノック 64本目：リンクされた図（カメラ機能）

・出題・頂いた回答・解説・補足・サイト内関連ページ

同じテーマ「VBA100本ノック」の記事

87本目：数式のシート間の依存関係
 88本目：クロスABC分析作成
 89本目：2つのフォルダの統合
90本目：セルに重なっている画像の削除
91本目：時間計算（残業時間の月間合計）
92本目：セルの色を16進で返す関数
 93本目：複数ブックを連結して再分割
 94本目：表範囲からHTMLのtableタグを作成
 95本目：図形のテキストを検索するフォーム作成
 96本目：Accessデータを取得（マスタ結合&抽出）
97本目：Accessデータを取得（グループ集計）

アクセスランキング・・・ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
3.RangeとCellsの使い方｜VBA入門
4.ひらがな⇔カタカナの変換｜エクセル基本操作
5.繰り返し処理（For Next)｜VBA入門
6.変数宣言のDimとデータ型｜VBA入門
7.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
8.並べ替え（Sort）｜VBA入門
9.セルのクリア（Clear,ClearContents）｜VBA入門
10.Findメソッド（Find,FindNext,FindPrevious）｜VBA入門

ホーム
マクロVBA入門編
VBA100本ノック
90本目：セルに重なっている画像の削除

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。

記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。

VBA練習問題
VBA100本ノック 90本目：セルに重なっている画像の削除