図形オブジェクト(Shape)の位置がセル範囲内にあるかどうかを判定して、
ある範囲内のすべての図形オブジェクトを処理する方法を解説します。
この方法を使った便利マクロ
「選択セル範囲の中にあるすべての図形オブジェクトを選択するマクロ」
も紹介します。
こんなマクロですね↓
図形を一括削除したり、グループ化や移動、
拡大縮小をまとめて行うときにとても便利なマクロです。
実行型の便利マクロですので、
Excel起動時に裏で開かれる「個人用マクロブック」などに搭載して使ってください。
ショートカットキーに登録したり、ツールバーやリボンにボタン配置すると便利です。
セル範囲内のすべての図形を取得して処理するコード
Shapeオブジェクトの位置が指定セル範囲内にあるかを判定し、
セル範囲に含まれるすべてのShapeオブジェクトを処理するコードを解説します。
完成品をコピペで持ってくだけだから解説なんていらない不届き者方は、
この部分は読み飛ばして便利マクロのソースコードまで進んでください。
セル範囲に含まれるすべてのShapeオブジェクトを取得するコードがこちらです↓
Sub 指定セル範囲内のShapeオブジェクトを処理する(指定セル範囲 As Range) Dim shp As Shape For Each shp In 指定セル範囲.Worksheet.Shapes Dim shpを含む最小セル範囲 As Range Set shpを含む最小セル範囲 = Range(shp.TopLeftCell, shp.BottomRightCell) If Not Intersect(shpを含む最小セル範囲, 指定セル範囲) Is Nothing Then If Intersect(shpを含む最小セル範囲, 指定セル範囲).Address _ = shpを含む最小セル範囲.Address Then ' ここにshapeオブジェクトごとに行う処理を書く End If End If Next End Sub
このコードのロジックは以下の通りです↓
- すべてのShapeオブジェクトをFor Each文でループする
- そのShapeオブジェクトを含む最小のセル範囲を取得する
- その最小セル範囲と指定セル範囲が重なっているか判定する
結構単純なコードですね。
まず「あるShapeオブジェクトを含む最小のセル範囲」は、
Range(Shapeの左上のセル, Shapeの右下のセル)で求めることができます。
左上セル・右下セル共に、TopLeftCell/BottomRightCellという一発で取得できるプロパティが用意されているので簡単ですね。
そうして取得した「Shepeを含む最小セル範囲」が指定範囲に含まれているかは、
こちらもストレートにそれを判定してくれるIntersectメソッドを使えばOKです。
- 交差範囲があれば
- ⇒さらに交差範囲が最小セル範囲と完全に一致していれば
とIf文をネストすることで「範囲に含まれる図形」を表現していますが、
2個目のIf文を消せば「範囲と重なる図形」に変えることもできます。
処理の内容に合わせて使い分けてください。
図形に対する処理ですが、例えば削除をしたい場合は、
shp.Delete
をShapeごとの処理部分に書きます。
今回の便利マクロで行う「図形の選択」をするのであれば、
shp.Select Replace:=False
を書くだけでOKです。
Shapesオブジェクト.Selectで図形オブジェクトを選択できますが、
引数ReplaceをFalseにすれば、今の選択図形たちに追加選択ができます。
まずまとめてからSelectする必要のあるRangeオブジェクトと違い、
Shapeオブジェクトは順次Selectしていけるのが便利ですね。
メインコードの解説は以上です。
実際のマクロは細かい例外処理が入りますし、
加えて便利マクロには痒い所に手が届く仕様にしたくなるので、
どうしてもコードが長くなってしまいます。
しかしメインコードは割と単純ですので、
まずはここまでで必要なプロパティを覚えてしまってください。
選択範囲内のすべての図形を選択するマクロ
では実際に作成した便利マクロの解説に入ります。
ちなみに、一応これに似たExcelの標準機能として、
「ホーム」→「検索と選択」→「オブジェクトの選択」
で、ドラッグ範囲内の図形を選択することができます。
こちらはモード切替が必要で、選択モード中は逆にセルが選択できなくなるためあまり好きではないのですが、Excelの標準機能ですので、これを知った上でマクロも見ていただければと思います。
では始めます。
ソースコード
Sub 選択範囲内のすべての図形を選択する() On Error Resume Next ' SelectionがRangeでなければシートの全図形を選択 If TypeName(Selection) <> "Range" Then ActiveSheet.Shapes.SelectAll Exit Sub End If Dim 選択範囲 As Range: Set 選択範囲 = Selection ' シート内の全図形をループ Dim shp As Shape For Each shp In ActiveSheet.Shapes ' 図形が枠線に合わせて設置されている場合の右下セルを位置調整 Dim BRCell位置調整 As Range Set BRCell位置調整 = shp.BottomRightCell If WorksheetFunction.Round(shp.Top + shp.Height - BRCell位置調整.Top, 2) = 0 Then Set BRCell位置調整 = BRCell位置調整.Worksheet.Cells(BRCell位置調整.Row - 1, BRCell位置調整.Column) End If If WorksheetFunction.Round(shp.Left + shp.Width - BRCell位置調整.Left, 2) = 0 Then Set BRCell位置調整 = BRCell位置調整.Worksheet.Cells(BRCell位置調整.Row, BRCell位置調整.Column - 1) End If ' 図形を含む最小セル範囲が選択範囲に含まれていれば選択図形に追加 Dim shpを含む最小セル範囲 As Range Set shpを含む最小セル範囲 = Range(shp.TopLeftCell, BRCell位置調整) If Not Intersect(shpを含む最小セル範囲, 選択範囲) Is Nothing Then If Intersect(shpを含む最小セル範囲, 選択範囲).Address _ = shpを含む最小セル範囲.Address Then shp.Select False End If End If Next ' 選択範囲に図形がない = SelectionがRangeのまま変わっていなければシートの全図形を選択 If TypeName(Selection) = "Range" Then ActiveSheet.Shapes.SelectAll Exit Sub End If End Sub
解説
まず、マクロの上下にある
ActiveSheet.Shapes.SelectAll
は、シート内の全図形の選択です。
- セル範囲(Range)以外を選択して実行したとき
- 選択範囲内に図形オブジェクトがなかったとき
- 単独セルから実行したとき
に、「シート内のすべての図形を選択するマクロ」として動かすことで、
ひとつのボタン/ショートカットでハイブリッドなマクロにしています。
続いてBottomRightCellの位置調整ですが、
BottomRightCellにはちょっと微妙な仕様があります。
図形を「枠線に合わせる」設定で動かしたり、
Altキーを押しながら図形を移動して枠線に合わせたときに、
BottomRightCellはこうなります↓
シートのグリッド線は右下のセルのものという扱いなのか、
グリッド線上の図形は右下に1つズレてしまいます。
※ TopLeftCellは大丈夫
なので、図形を含む最小セル範囲を
Range(shp.TopLeftCell, shp.BottomRightCell)
で取ってしまうと、右下ギリギリの図形が選択されてくれません。
まあこれで何か問題かというとそうでもなく、
ちょっと広めに選択するだけでいいんですけどね。
よほどぎちぎちに図形を詰め込んでいるシートでもなければ大丈夫ですし、
そんなシートは「マクロより先にその図形をなんとかしろ」と言いたくなります。
なので私の個人マクロはこの問題を無視していたのですが、
ブログで世に公開するとなると、
なんか「仕様です」とは言いづらかったのでちゃんと実装しました。
内容としては、
- Shapeの下端(右端)とBottomRightCellの上端(左端)が一致していたら
- BottomRightCellの位置を1つ上に(左に)ズラす
コードを書けばよいです。
面倒なのがShapeオブジェクトがBottom/Rightプロパティを持っていないことで、
Top + Height（上端から高さ分下へ）で計算します。
よってストレートなコードを書くと、
If shp.Top + shp.Height = BottomRightCell.Top Then Set BRCell位置調整 = BottomRightCell.Offset(-1) End If
こうなります。
が、「小数の足し算は誤差が発生する」という罠がありますので、
行列のピクセルで表現できる小数点第2位を四捨五入して、
If WorksheetFunction.Round(shp.Top + shp.Height - BRCell位置調整.Top, 2) = 0 Then
というIf文にしています。
Roundを3連発書きたくないので、
A=B を A-B=0 に移項して、左辺を全部四捨五入ですね。
続いて、Shape右下のセルがもし結合されていた場合、
「結合セルからのOffsetは移動が1セルとは限らない」という罠があります。
渡るVBA界は罠だらけ＼(^o^)／
なので面倒ですが、If文の中身はCells(R-1, C)で実装して、
Set BRCell位置調整 = BRCell位置調整.Worksheet.Cells(BRCell位置調整.Row - 1, BRCell位置調整.Column)
こう書いています。
そうやって調整した右下セルを使って
Set shpを含む最小セル範囲 = Range(shp.TopLeftCell, BRCell位置調整)
を取ればやっと完成ですね。
最後に小ネタですが、変数名を語順的に自然な「位置調整BRCell」にしないで、
「BRCell位置調整」にしているのは、BRC+Ctrl+Spaceで入力できるからです。
日本語入力のONOFFを切り替えるの面倒ですからね。
「shpを含む最小セル範囲」も、shp+Ctrl+SpaceでOK。
子音を連続させておくと予測候補が絞られておすすめです。
ということで、ソースコードの解説を終わります。
どんなファイルでも実行できるような便利マクロを作るときは、
細かい例外処理が多くなって普通のマクロよりちょっと手間です。
ですが、手間をかけておくと痒い所に手が届くマクロにできますので、
この辺の微調整をサボらず丁寧にやっておきましょう。
(ブログに公開するまでサボってたけど)
Excelで図形をよく扱う方は、ALLのショートカットの派生っぽく、
Ctrl+Shift+Aあたりにこのマクロをセットしておくと捗ると思います。
是非ご活用ください。
選択範囲内のすべての図形を削除するマクロ
この便利マクロの派生で、
「選択セル範囲内のすべての図形を削除するマクロ」
も作りたくなります。
さっとセル範囲を選択して、パッと図形を消せると便利ですからね。
しかし、便利マクロ全般に言えることなのですが、
マクロを使うと「元に戻す」が使えなくなるというデメリットがあります。
なので、便利マクロとして実装するのは、
本記事の「選択する」マクロまでがいいと思います。
そのあと削除するならDeleteキー1回で済みますしね。
手間もほとんど変わらず、消す前の確認もできますし、
なによりDeleteキーならCtrl+Zが効きますから。
このマクロに限らず、
削除系の便利マクロはその一歩手前の「選択」で止める方が便利です。
そのあとの操作を手で行えばそこで「元に戻す」ことは当然できますし、
このマクロはSelectしかしていませんので、
マクロ実行前の「元に戻す」も生かしたまま実行することが可能です。
それでもどうしても「一括削除」マクロが欲しい場合は、
shp.Select False
を
shp.Delete
に変えれば「選択セル範囲内のすべての図形を削除するマクロ」は作れます。
がしかしその時は、
「Shapesコレクションにはドロップダウンリストの▼が含まれる」
という新たな罠を回避するために、
For Each shp In ActiveSheet.Shapes If Not shp.Name Like "Drop Down*" Then
を追加してください。
詳しくはこちらをどうぞ。
ついでに途中にあった罠はこれです↓
www.limecode.jp
まあこれらの罠は詳しい解説をみなくても、
そんな落とし穴があると軽く知っておくだけでも十分意味があります。
心の片隅にでも、置いておいてください。
