こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

エクセル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に入力されるデータが1,2,3,4の4種類、AQ11に5,6,7,8,9の5種類などと、ばらばらです。
P11に1が入力されるとN14:N15(結合されています)に円が入り、2が入力されるとN16に円が入る。
Q11に5が入力されるとR13に円が入り、6が入力されるとR14:R15に円が入る・・・・のようにしたいのです。
一生懸命、セルNo.を打ち込んでいたら、
「コンパイルエラー:プロシージャが大きすぎます」とエラーが出てしまいました。
ループさせればよいのだろうと試してみたのですが、元のセルの指定方法や、オートシェイプの出現させるせるの指定方法がわかりません。
どのようにすれば、データー元の範囲を指定して、それに対応したセルにオートシェイプを出現させる事が出来るようになるでしょうか。
お知恵を貸していただけないでしょうか。よろしくお願い致します。

投稿日時 - 2010-03-08 01:36:58

QNo.5734069

困ってます

質問者が選んだベストアンサー

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

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

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

投稿日時 - 2010-03-08 09:00:57

お礼

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

投稿日時 - 2010-03-13 00:30:09

ANo.2

このQ&Aは役に立ちましたか?

4人が「このQ&Aが役に立った」と投票しています

回答(4)

ANo.4

#3です
すみません、訂正です
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

参考まで

投稿日時 - 2010-03-11 05:15:29

お礼

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

投稿日時 - 2010-03-13 00:26:51

ANo.3

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

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

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

参考まで

投稿日時 - 2010-03-11 05:12:03

ANo.1

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

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

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

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

投稿日時 - 2010-03-08 04:26:05

お礼

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

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

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

投稿日時 - 2010-03-08 06:38:34

あなたにオススメの質問