エクセルVBA オートシェイプを操作したいです

質問

エクセルでセルの入力内容によって楕円をオートシェイプで出現させたいと思います。
http://oshiete1.goo.ne.jp/qa809742.htmlで見つかったものを参考にし、

Private Sub worksheet_Activate()
Dim Shp As Shape
Set P11 = Range("P11")
If P11 Is Nothing Then Exit Sub
If P11.Value = 1 Then
For Each Shp In ActiveSheet.Shapes
If Not Application.Intersect(Shp.TopLeftCell, _
Range("N14:N15")) Is Nothing Then
Shp.Delete
End If
Next Shp
With ActiveSheet.Range("N14:N15")
ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, _
Left:=.Left,TOP:=.TOP,Width:=.Width,Height:=.Height).Select
Selection.ShapeRange.Fill.Visible = msoFalse
End With
Range("N14").Select
Else
For Each Shp In ActiveSheet.Shapes
If Not Application.Intersect(Shp.TopLeftCell, _
Range("N14:N15")) Is Nothing Then
Shp.Delete
End If
Next Shp
End If
If P11.Value = 2 Then
For Each Shp In ActiveSheet.Shapes
If Not Application.Intersect(Shp.TopLeftCell, _
Range("N16")) Is Nothing Then
Shp.Delete
End If
Next Shp
With ActiveSheet.Range("N16")
ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, _
Left:=.Left, TOP:=.TOP, Width:=.Width, Height:=.Height).Select
Selection.ShapeRange.Fill.Visible = msoFalse
End With
Range("N16").Select
Else
For Each Shp In ActiveSheet.Shapes
If Not Application.Intersect(Shp.TopLeftCell, _
Range("N16")) Is Nothing Then
Shp.Delete
End If
Next Shp
End If
End Sub

とつなげて見ました。
動くには動くのですが、データ元のセルがP11からT30と100セルあり、さらにP11に入力されるデータが１，２，３，４の4種類、AQ11に５，６，７，８，９の5種類などと、ばらばらです。
P11に１が入力されるとN14:N15(結合されています)に円が入り、２が入力されるとN16に円が入る。
Q11に５が入力されるとR13に円が入り、６が入力されるとR14:R15に円が入る・・・・のようにしたいのです。
一生懸命、セルNo.を打ち込んでいたら、
「コンパイルエラー：プロシージャが大きすぎます」とエラーが出てしまいました。
ループさせればよいのだろうと試してみたのですが、元のセルの指定方法や、オートシェイプの出現させるせるの指定方法がわかりません。
どのようにすれば、データー元の範囲を指定して、それに対応したセルにオートシェイプを出現させる事が出来るようになるでしょうか。
お知恵を貸していただけないでしょうか。よろしくお願い致します。

回答No.2

mimeu · ベストアンサー

> この今書いてある前文のようなところに、
> 楕円を描く、楕円を消去のものが来て、
> その続きに本文という形になりますか？

サブルーチンは入れ子にはできません。
例えば下はエラーになります

Sub ABC()
　　ああでもない、こうでもない
　　Sub EFG()
　　　　ナンチャラカンチャラ
　　End Sub
　　どうたらこうたら
End Sub

なので、ご質問のばあい以下のように書きます

Private Sub worksheet_Activate()
　　中略
　　If Range("P11")=1 Then 楕円を描く "N14:N15" Else 楕円を消去 "N14:N15"
　　If Range("P11")=2 Then 楕円を描く "N16" Else 楕円を消去 "N16"
　　以下省略
End Sub

Private Sub 楕円を描く(描画範囲 As Range)
　　楕円を消去 描画範囲
　　楕円を描画するロジック
　　あ～たらこ～たら
End Sub

Sub Sub 楕円を消去(描画範囲 As Range)
　　Dim Shp As Shape
　　そこに既に楕円があれば消去するロジック
　　あれやこれや
End Sub

お礼

サブルーチンを組む事ができました。
無事に全てのセルに対して条件を付け稼動する事ができるようになりました。
今後、サブルーチンを活用できるようにＶＢＡを勉強していきます。
ありがとうございました。

回答No.4

hige_082

＃３です
すみません、訂正です
selectcase終わらせるのを忘れてました

Private Sub Worksheet_Activate()
Dim Shp As Shape
Dim P11 As Range
Dim Rng As Range

Set P11 = Range("P11")

If P11 Is Nothing Then Exit Sub
ActiveSheet.Shapes.SelectAll.Delete
Selection.Delete

Select Case P11.Value
Case 1: Set Rng = Range("N14:N15")
Case 2: Set Rng = Range("N16")
End Select

With Rng
ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height).Select
Selection.ShapeRange.Fill.Visible = msoFalse
End With

Set P11 = Nothing
Set Rng = Nothing
End Sub

参考まで

お礼

select caseを使用して稼動する事ができました。
ありがとうございます。

回答No.3

hige_082

入力セルと出力セルの関係が
よく読み取れなかったので
＞「コンパイルエラー：プロシージャが大きすぎます」とエラーが出てしまいました。
についての、アドバイスです

質問のマクロを整理すると
この様になると思います

Private Sub Worksheet_Activate()
Dim Shp As Shape
Dim P11 As Range
Dim Rng As Range

Set P11 = Range("P11")

If P11 Is Nothing Then Exit Sub
ActiveSheet.Shapes.SelectAll.Delete
Selection.Delete

Select Case P11.Value
Case 1: Set Rng = Range("N14:N15")
Case 2: Set Rng = Range("N16")

With Rng
ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height).Select
Selection.ShapeRange.Fill.Visible = msoFalse
End With

Set P11 = Nothing
Set Rng = Nothing
End Sub

参考まで

回答No.1

mimeu

ご質問を一見して思ったのは、☆ サブルーチンを使えばよい ☆
という事です。普通こんな書き方はしません。
例えば、以下のふたつでのサブルーチンを作ります。

Sub 楕円を描く(描画範囲 As Range)
　　そこに既に楕円があれば消去する
　　そこに楕円を描画する
End Sub

Sub 楕円を消去(描画範囲 As Range)
　　そこに既に楕円があれば消去する
End Sub

そして本文では、例えば
　　If Range("P11")=1 Then 楕円を描く "N14:N15" Else 楕円を消去 "N14:N15"
という風に記述すれば、プログラムはウンと簡単になります。

お礼

ありがとうございます。
サブルーチン、勉強してみます。

私の解釈ですが、この今書いてある前文のようなところに、
楕円を描く、楕円を消去のものが来て、
その続きに本文という形になりますか？

サブルーチンは同じPrivate　Subの中に置いておいて大丈夫ですか。