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

VBAを100本の練習問題で鍛えます
最終更新日:2021-02-22

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


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


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

VBAテスト用のサンプルデータは、VBA100本ノックの目次ページ からもダウンロードできます。
マクロVBAを初心者向けの基本から上級者向けの高度な内容までサンプルコードを掲載し解説しています。エクセル関数・機能・基本操作の入門解説からマクロVBAまでエクセル全般を網羅しています。


出題

出題ツイートへのリンク

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

マクロ VBA 100本ノック


サンプルファイルです。
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の注意点
マクロ VBA 100本ノック

マクロ VBA 100本ノック

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


TopやLeftの数値誤差の発生
マクロ VBA 100本ノック

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

マクロ VBA 100本ノック
マクロ VBA 100本ノック

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

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

マクロ VBA 100本ノック
マクロ VBA 100本ノック

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

ShapesとPictureでは数値に差異があります
マクロ VBA 100本ノック


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


サイト内関連ページ

100本ノック 29本目:画像の挿入
指定の画像をアクティブセル内に収まるように貼り付ける問題です。ツイッター連動企画です。ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。VBAテスト用のサンプルデータはご自身でご用意ください。
100本ノック 64本目:リンクされた図(カメラ機能)
「元表1」「元表2」の2シートの表範囲を「リンクされた図」として「まとめ」シートに貼り付ける問題です。ツイッター連動企画です。ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。




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

85本目:請求日から入金予定日を算出
86本目:全シートの総当たり表を作成
87本目:数式のシート間の依存関係
88本目:クロスABC分析作成
89本目:2つのフォルダの統合
90本目:セルに重なっている画像の削除
91本目:時間計算(残業時間の月間合計)
92本目:セルの色を16進で返す関数
93本目:複数ブックを連結して再分割
94本目:表範囲からHTMLのtableタグを作成
95本目:図形のテキストを検索するフォーム作成


新着記事NEW ・・・新着記事一覧を見る

エクセル馬名ダービー|エクセル雑感(2021-07-21)
在庫を減らせ!毎日棚卸ししろ!|エクセル雑感(2021-07-05)
日付型と通貨型のValueとValue2について|エクセル雑感(2021-06-26)
DXってなんだ? ITと何が違うの?|エクセル雑感(2021-06-24)
エクセルVBA 段級位 目安|エクセル雑感(2021-06-21)
ローカル版エクセルが「Office Scripts」に変わる日|エクセル雑感(2021-06-10)
新関数SORTBYをVBAで利用するラップ関数を作成|VBA技術解説(2021-06-12)
VBA今日のひとこと/VBA今日の教訓 on Twitter|エクセル雑感(2021-06-10)
VBAの演算子まとめ(演算子の優先順位)|VBA技術解説(2021-06-09)
画像が行列削除についてこない場合の対処|VBA技術解説(2021-06-04)


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

1.最終行の取得(End,Rows.Count)|VBA入門
2.Excelショートカットキー一覧|Excelリファレンス
3.変数宣言のDimとデータ型|VBA入門
4.RangeとCellsの使い方|VBA入門
5.繰り返し処理(For Next)|VBA入門
6.マクロって何?VBAって何?|VBA入門
7.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
8.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
9.セルに文字を入れるとは(Range,Value)|VBA入門
10.とにかく書いてみよう(Sub,End Sub)|VBA入門




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


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



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