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

VBAを100本の練習問題で鍛えます
公開日:2021-02-17 最終更新日: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本目:画像の挿入
・出題 ・頂いた回答 ・解説 ・補足 ・サイト内関連ページ
100本ノック 64本目:リンクされた図(カメラ機能)
・出題 ・頂いた回答 ・解説 ・補足 ・サイト内関連ページ




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

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


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

TRIMRANGE関数(セル範囲をトリム:端の空白セルを除外)|エクセル入門(2024-08-30)
正規表現関数(REGEXTEST,REGEXREPLACE,REGEXEXTRACT)|エクセル入門(2024-07-02)
エクセルが起動しない、Excelが立ち上がらない|エクセル雑感(2024-04-11)
ブール型(Boolean)のis変数・フラグについて|VBA技術解説(2024-04-05)
テキストの内容によって図形を削除する|VBA技術解説(2024-04-02)
ExcelマクロVBA入門目次|エクセルの神髄(2024-03-20)
VBA10大躓きポイント(初心者が躓きやすいポイント)|VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成|ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。|エクセル雑感(2024-02-17)
初級脱出10問パック|VBA練習問題(2024-01-24)


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

1.最終行の取得(End,Rows.Count)|VBA入門
2.繰り返し処理(For Next)|VBA入門
3.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
4.変数宣言のDimとデータ型|VBA入門
5.RangeとCellsの使い方|VBA入門
6.ブックを閉じる・保存(Close,Save,SaveAs)|VBA入門
7.セルのクリア(Clear,ClearContents)|VBA入門
8.メッセージボックス(MsgBox関数)|VBA入門
9.条件分岐(Select Case)|VBA入門
10.ブック・シートの選択(Select,Activate)|VBA入門




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


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


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