指定範囲内のオートシェイプを数えるには？

I5:I24の範囲内のオートシェイプの数を数え、I25に合計数を表示させるマクロを作っているのですが、どうしても範囲指定の仕方が分かりません。教えてください。

'オートシェイプの合計数算出
Dim shp As Object
Dim cnt As Long
For Each shp In ActiveSheet.Shapes
If shp.Type = msoAutoShape Then
If shp.TopLeftCell.Column = 9 Then
cnt = cnt + 1
End If
End If
Next shp
Range("I25").Value = cnt
このマクロのどこにどう入れればよいでしょうか？

No.1 ベストアンサー 回答者： watabe007 回答日時： 2009/10/07 14:01

TopLeftCellプロパティとIntersect メソッドを使って

図形の左上端が範囲内にあるか判定します

Dim shp As Object
Dim cnt As Long

For Each shp In ActiveSheet.Shapes
　　If shp.Type = msoAutoShape Then
　　　　If Not Intersect(shp.TopLeftCell, Range("I5:I24")) Is Nothing Then
　　　　　　cnt = cnt + 1
　　　　End If
　　End If
Next shp
Range("I25").Value = cnt

図形の右下も含めるのならBottomRightCellプロパティ
も条件に含めてください

この回答へのお礼

お礼遅くなり申し訳ありません。
ありがとうございました。

お礼日時：2010/10/04 13:52

No.3 回答者： imogasi 回答日時： 2009/10/07 21:06

もともとオートシェイプなどの、シート上のオブジェクトは、シートに浮かんで要るようなもので、EXCELのシートのセルとは何の関係もないものです。

すなわちセルの属性ではない。
しかしそれでは不便な場合もあるので、
Sub test01()
MsgBox ActiveSheet.Shapes.Count
MsgBox ActiveSheet.Shapes(1).Name
MsgBox ActiveSheet.Shapes(1).TopLeftCell.Address
MsgBox ActiveSheet.Shapes(1).BottomRightCell.Address
MsgBox ActiveSheet.Shapes(1).BottomRightCell.Column
End Sub
をやるとわかるように、位置関係について、オブジェクト側から
TopLeftCell、BottomRightCellの属性を使えるようになっている。
ほかに「オートシェイプの書式設定」の「プロパティ」の「セルにあわせて・・」のような仕組みがあるだけである。
ーー
だから、質問の、「範囲指定の仕方と言っても、TopLeftCell等の番地が、質問者の考える範囲内にある（InterSectする）か聞くほかない。
これもオブジェクトの位置を動かすと変わる不安定なものである。
ーー
InterSectを使わないなら、ActiveSheet.Shapes(1).TopLeftCellなどのRowとColumnについて、列について２よりで大６より小、且つ行について3より大で８より小のような判別（IFで）プログラムでやることになる。
ーーー
TopLeftCellとBottomRightCell　のどちらを問題にするのか、両方を考えるかの問題は、当然ある。

この回答へのお礼

お礼遅くなり申し訳ありません。
ありがとうございました。

お礼日時：2010/10/04 13:51

No.2 回答者： myRange 回答日時： 2009/10/07 14:35

＞範囲内のオートシェイプの数

この表現はちょっとあやふやです。
範囲に完全に入っているものの数か
範囲に少しでも入っているものの数か
どちらでしょう。

で、２通り数えるコードを。。

'------------------------------------------
Sub Test()
　Dim Shp As Shape
　Dim Cnt1 As Long
　Dim Cnt2 As Long
　Dim myRange As Range

　Set myRange = Range("H1:J20") '●調査範囲、適宜に変更

For Each Shp In ActiveSheet.Shapes
　If Shp.Type = msoAutoShape Then

'●範囲内に完全に入っているSHAPE
　If Not Intersect(Shp.TopLeftCell, myRange) Is Nothing And _
　　Not Intersect(Shp.BottomRightCell, myRange) Is Nothing Then
　　　　Cnt1 = Cnt1 + 1
　End If

'●範囲内に一部でも入っているSHAPE
　If Not Intersect(Shp.TopLeftCell, myRange) Is Nothing Or _
　　Not Intersect(Shp.BottomRightCell, myRange) Is Nothing Then
　　　　Cnt2 = Cnt2 + 1
　End If

　End If
Next Shp

　　Range("I25").Value = Cnt1
　　Range("I26").Value = Cnt2
End Sub
'-----------------------------------------------

以上です。
　

この回答へのお礼

お礼遅くなり申し訳ありません。
ありがとうございました。

お礼日時：2010/10/04 13:53