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


頂いた回答

解説

まずポイント解説から。
・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本ノック」の記事

86本目:全シートの総当たり表を作成
87本目:数式のシート間の依存関係
88本目:クロスABC分析作成
89本目:2つのフォルダの統合
90本目:セルに重なっている画像の削除
91本目:時間計算(残業時間の月間合計)
92本目:セルの色を16進で返す関数
93本目:複数ブックを連結して再分割
魔球編:組み合わせ問題
魔球編:閉領域の塗り潰し
迷宮編:巡回セル問題


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

VBA100本ノック 93本目:複数ブックを連結して再分割|VBA練習問題(2月22日)
VBA100本ノック 92本目:セルの色を16進で返す関数|VBA練習問題(2月20日)
VBA100本ノック 91本目:時間計算(残業時間の月間合計)|VBA練習問題(2月19日)
VBA100本ノック 90本目:セルに重なっている画像の削除|VBA練習問題(2月17日)
VBA100本ノック 89本目:2つのフォルダの統合|VBA練習問題(2月16日)
VBA100本ノック 88本目:クロスABC分析作成|VBA練習問題(2月15日)
VBA100本ノック 87本目:数式のシート間の依存関係|VBA練習問題(2月13日)
VBA100本ノック 86本目:全シートの総当たり表を作成|VBA練習問題(2月12日)
VBA100本ノック 85本目:請求日から入金予定日を算出|VBA練習問題(2月10日)
VBA100本ノック 84本目:ブックの自動バックアップ|VBA練習問題(2月9日)


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

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




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


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



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