![](http://oshiete.xgoo.jp/images/v2/pc/qa/question_title.png?e8efa67)
エクセルでセルの入力内容によって楕円をオートシェイプで出現させたいと思います。
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.を打ち込んでいたら、
「コンパイルエラー:プロシージャが大きすぎます」とエラーが出てしまいました。
ループさせればよいのだろうと試してみたのですが、元のセルの指定方法や、オートシェイプの出現させるせるの指定方法がわかりません。
どのようにすれば、データー元の範囲を指定して、それに対応したセルにオートシェイプを出現させる事が出来るようになるでしょうか。
お知恵を貸していただけないでしょうか。よろしくお願い致します。
No.2ベストアンサー
- 回答日時:
> この今書いてある前文のようなところに、
> 楕円を描く、楕円を消去のものが来て、
> その続きに本文という形になりますか?
サブルーチンは入れ子にはできません。
例えば下はエラーになります
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
サブルーチンを組む事ができました。
無事に全てのセルに対して条件を付け稼動する事ができるようになりました。
今後、サブルーチンを活用できるようにVBAを勉強していきます。
ありがとうございました。
No.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
参考まで
No.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
参考まで
No.1
- 回答日時:
ご質問を一見して思ったのは、☆ サブルーチンを使えばよい ☆
という事です。普通こんな書き方はしません。
例えば、以下のふたつでのサブルーチンを作ります。
Sub 楕円を描く(描画範囲 As Range)
そこに既に楕円があれば消去する
そこに楕円を描画する
End Sub
Sub 楕円を消去(描画範囲 As Range)
そこに既に楕円があれば消去する
End Sub
そして本文では、例えば
If Range("P11")=1 Then 楕円を描く "N14:N15" Else 楕円を消去 "N14:N15"
という風に記述すれば、プログラムはウンと簡単になります。
ありがとうございます。
サブルーチン、勉強してみます。
私の解釈ですが、この今書いてある前文のようなところに、
楕円を描く、楕円を消去のものが来て、
その続きに本文という形になりますか?
サブルーチンは同じPrivate Subの中に置いておいて大丈夫ですか。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) 【VBA】写真の貼り付けコードがうまく機能しません。 5 2022/09/01 18:43
- Excel(エクセル) エクセル VBA For Next 繰り返しの書き方を教えてください 6 2022/09/01 14:11
- Excel(エクセル) EXCEL マクロで行を挿入して貼り付けようとするとエラーになる。 2 2022/05/24 09:43
- Visual Basic(VBA) ExcelのVBAコードについて教えてください。 2 2022/05/26 17:19
- Visual Basic(VBA) excel2021で実行できないマクロ。どこを直したらいいのか 2 2022/03/28 03:40
- PowerPoint(パワーポイント) ExcelのVBAコードについて教えてください。 3 2022/05/25 14:32
- Excel(エクセル) VBA 1 2023/04/27 13:37
- Visual Basic(VBA) 形式を選択して貼り付け 以下のコードで「元」シートと「先」シートのA列に同じ値があったら指定範囲をコ 5 2022/11/11 07:30
- Visual Basic(VBA) VBAの繰り返し処理について教えてください。 3 2022/08/02 13:21
- Visual Basic(VBA) 【再々投稿】VBAのプログラムで動作しなくて困っています 8 2022/10/14 09:06
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
[AVIUTL]拡張編集にて、テキス...
-
パソコンに行書体がありません...
-
Illustratorでグループ化が解除...
-
資料としていただいたイラスト...
-
adobe PDFに変換すると.logファ...
-
pdfで、図形を回転する
-
イラストレータで内側に線を引...
-
フォトショップで青い線が出て...
-
Acrobatで作成した四角の前面・...
-
「U」のような図形を作成する方法
-
イラレでクリッピングマスクし...
-
Wordでアンカー記号が表示でき...
-
アスタリスクににているマーク...
-
PDF-Xchange Viewerのスタンプ...
-
Illustrator ペンツールのポイ...
-
Macにもともと入っているHelvet...
-
イラストレーターの白を透明に...
-
埋め込み動画のURLを知りたいで...
-
indesignでのフォント一括変換
-
DTPです、モリサワ リュウミン...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
エクセルの塗りつぶし
-
illustratorで横文字入力出来な...
-
テキスト入力が180度反転してし...
-
JWCADの変形した楕円の描き方
-
紙を焼いた後のような加工の方法
-
メタセコイアで楕円柱の書き方
-
写真を丸く保存したいです
-
[AVIUTL]拡張編集にて、テキス...
-
コントロールパネルの塗りの設...
-
楕円の塗りつぶし
-
エクセル:チェックボックスで...
-
Illustrator楕円で塗り透明、線...
-
Illusrator10で、リング帳のイ...
-
楕円にフィッティングする画像...
-
fireworksで画像を丸く切り抜き
-
エクセル:チェックボックスで...
-
Adobe Illastrator CSにおいて...
-
PhotoShopで曲がったスキャン画...
-
illustratorでペンタブの筆圧設...
-
エクセルVBA オートシェイプを...
おすすめ情報