- ベストアンサー
エクセルVBAでの複数のオートシェイプの色塗り方法
watabe007の回答
>セル"A1"や"A2"に計算式（関数など）が入っている場合は 数式によりセルの値が変化してもWorksheet_Changeイベントは 動かないのでWorksheet_Calculateイベントを使ってみましょう Private Sub Worksheet_Calculate() Dim shp(1 To 2) As Shape Dim c As Range, i As Long Set shp(1) = ActiveSheet.Shapes("A") Set shp(2) = ActiveSheet.Shapes("B") For Each c In Range("A1:A2") i = i + 1 Select Case c.Value Case 1 shp(i).Fill.ForeColor.RGB = RGB(255, 0, 0) '赤 Case 2 shp(i).Fill.ForeColor.RGB = RGB(255, 255, 0) '黄 Case 3 shp(i).Fill.ForeColor.RGB = RGB(0, 128, 0) '緑 Case 4 shp(i).Fill.ForeColor.RGB = RGB(0, 0, 255) '青 Case Else shp(i).Fill.ForeColor.RGB = RGB(255, 255, 255) '白 End Select Next End Sub
関連するQ&A
- エクセルVBAオートシェイプがあったら、の書き方
皆さんこんにちは。 エクセルVBAの初心者です。 IFを使った条件分岐が私には難しかったので SELECTCASEを用いてみようと思うのですが条件の書き方が分かりません。 やりたい事は セルA1が「文字が入っていない且つオートシェイプが入っていない場合」のみ アクション（オートシェイプ☆を貼る）を起こしたい、です。 イメージ的にこうなるかな？と思いコードを作成しましたが ケース2の「オートシェイプがあったら」という条件の書き方が分かりません。 Sub オートシェイプ貼り付け() With ThisWorkbook.Worksheets("Sheet1") Select Case True Case .Range("A1").Value <> "" Exit Sub Case オートシェイプがあったら Exit Sub Case Else オートシェイプ☆を貼る End Select End Sub オートシェイプの有無を条件にするにはどのような書き方をすれば良いでしょうか？
- ベストアンサー
- Excel（エクセル）
- VBAでオートシェイプの制御？
エクセルマクロでセルにオートシェイプを張る方法を調べていて、ここで丁度いいのを見つけました。 http://oshiete1.goo.ne.jp/kotaeru.php3?q=808898 見つけた下記のマクロを実際にやってみました。 A1に１を入れるとB2にハートマークが出ます。 しかし、さらに２を入力してもB2のハートは削除されてくれません。 さらに１をいれると、ハートの上にハートが重なってしまいます。 １ならハート、それ以外の入力ならハートが消えるようにするにはどうすればいいのでしょうか？ Private Sub Worksheet_Change(ByVal Target As Range) If Target <> Range("A1") Then Exit Sub If Target.Value = 1 Then With ActiveSheet.Range("B2") ActiveSheet.Shapes.AddShape(Type:=msoShapeHeart, _ Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height).Select End With End If End Sub
- ベストアンサー
- オフィス系ソフト
- EXCEL 異なるVBA
教えて下さい、EXECL以下の異なるVBA (A>,B>)が２つあります、同じシートでそれぞれ動くようにさせたいです1つに合わせる事は出来ないでしょうか? 当方初心者の為わかりません教えて下さい。 A> Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address(0, 0, xlA1, 0) <> "A1" Then Exit Sub With Range("F9:I9,K17:K36").Borders(xlDiagonalUp) If Left$(Target.Value, 1) = "S" Then .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic Else .LineStyle = xlNone End If End With End Sub B> Private Sub Worksheet_Change(ByVal Target As Range) With Sheet2 Select Case Target.Address Case Is = "$D$1" .Range("A1").Insert Shift:=xlDown .Range("A1").Value = Target.Value Case Is = "$D$2" .Range("B1").Insert Shift:=xlDown .Range("B1").Value = Target.Value End Select End With End Sub
- 締切済み
- その他([技術者向] コンピューター)
- エクセルVBAでオートシェープを円く動かしたい。
星型をシート上で回転しながらぐるっと円周のように動かそうと、ためしに下記のマクロを書きましたが、やはり方向転換がぎこちなく、スムーズな丸い動きにはなりません。 かと言って、上下左右以外に動かす方法はないでしょうし、何かいいやり方はないでしょうか？ Sub Star() With ActiveSheet.Shapes.AddShape(msoShape5pointStar, 273#, 43#, 50#, 50#) .Fill.ForeColor.SchemeColor = 13 .Line.Weight = 0.75 .Line.ForeColor.SchemeColor = 64 For i = 1 To 180 a = 1 b = 1 If i > 90 Then a = -1 If i < 45 Or i > 135 Then b = -1 .IncrementRotation 2 .IncrementTop 2 * a .IncrementLeft -2 * b DoEvents Next End With End Sub
- ベストアンサー
- オフィス系ソフト
- エクセル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.を打ち込んでいたら、 「コンパイルエラー：プロシージャが大きすぎます」とエラーが出てしまいました。 ループさせればよいのだろうと試してみたのですが、元のセルの指定方法や、オートシェイプの出現させるせるの指定方法がわかりません。 どのようにすれば、データー元の範囲を指定して、それに対応したセルにオートシェイプを出現させる事が出来るようになるでしょうか。 お知恵を貸していただけないでしょうか。よろしくお願い致します。
- ベストアンサー
- その他MS Office製品
- エクセルVBAでLineの一括処理
ワークシート上に配置した複数のオートシェープの線（Lines）に対し、一括して太さと色を変えるにはどのようなコードになるのでしょうか？ 勿論以下のTEST01のように名前で指定すれば可能なのですが、TEST02のような全てのLineということはできないのでしょうか？ Sub Test01() With ActiveSheet.Shapes.Range(Array("Line 259", "Line 260")) .line.Weight = 1.75 .line.ForeColor.SchemeColor = 13 End With End Sub ↓実行時エラーとなる Sub Test02() With ActiveSheet.Lines .line.Weight = 2.5 .line.ForeColor.SchemeColor = 10 End With End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルVBAでオートシェープの連番はいくつまで使えますか？
シート上にオートシェープを配置すると、自動で名前と番号が振られます。（直線 125 とか 図 126とか） この番号は連番になっており、配置したオートシェープを全て削除してファイルを保存しても、次回はオートシェープが何もないにもかかわらず、次の番号から採番されます。 この番号はいったい幾つまで続くのでしょうか？ 下記VBAを試してますが、現在7万番台でもまだ有効に採番されます。 ある番号になったらそれ以上オートシェープが作れなくなるという話も聞きましたので質問します。 Sub test01() Randomize With ActiveSheet .Cells.Interior.ColorIndex = 1 CL = Int((50 * Rnd) + 1) L1 = Int((700 * Rnd) + 20) H1 = Int((450 * Rnd) + 20) Set SA = .Shapes.AddShape(msoShape5pointStar, L1, H1, 25, 25) SA.Name = "Merlion_" & SA.Name SA.Fill.ForeColor.SchemeColor = CL For n = 1 To 100 CL = Int((50 * Rnd) + 1) L2 = Int((600 * Rnd) + 20) H2 = Int((300 * Rnd) + 20) SA.Top = H2 - SA.Width / 2 SA.Left = L2 - SA.Height / 2 SA.Fill.ForeColor.SchemeColor = CL Set SL = .Shapes.AddLine(L1, H1, L2, H2) SL.Name = "Merlion_" & SL.Name Application.StatusBar = SL.Name SL.line.Weight = 0.75 SL.line.ForeColor.SchemeColor = CL L1 = L2 H1 = H2 Next SA.ZOrder msoBringToFront SA.line.Visible = True SA.line.ForeColor.SchemeColor = CL For i = 1 To 800 Step 60 SA.Rotation = i / 10 SA.line.Weight = i DoEvents Next For Each s In .Shapes If s.Name Like "Merlion_*" Then s.Delete Next .Cells.Interior.ColorIndex = xlNone End With End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルＶＢＡで指定範囲内のオートシェープを選択
エクセル２０００です。 仮にワークシートのRange("A1:B5")の範囲の中に貼り付けられたオートシェープの直線をまとめて選択する場合にはどのように書けばいいのでしょうか？ Sub TEST() Application.Intersect(Range("A1:B5"), ActiveSheet.Lines).Select End Sub とやってみましたが、エラーでした。 どうぞよろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- エクセルVBAでTargetのセルに設定された「名前の定義」の取得方法は？
例えば、A1、B2、C3セルに「名前の定義」で、それぞれ入力A、入力B、入力C という名前がつけてあります。 それらのセルに入力があった場合、Select Caseで分岐させ作動するマクロをつくりました。 簡略化すると以下のようなもので、一応正しく作動します。 Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, Range("入力A,入力B,入力C")) Is Nothing Then Exit Sub Select Case Target.Address(0, 0) Case "A1" MsgBox "A処理します。" Case "B2" MsgBox "B処理します。" Case "C3" MsgBox "C処理します。" End Select End Sub ただ、せっかくセルに名前を定義してあるのに、個々の入力セルの判定をTarget.Addressでしているのが不満です。 (￣～￣;) 定義された名前を使えないかと以下のようにやってみましたが実行時エラーで「サポートしてません」となってしまいます。 (T.T) Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, Range("入力A,入力B,入力C")) Is Nothing Then Exit Sub Select Case Target.Names.Name 'ここでエラー Case "入力A" MsgBox "A処理します。" Case "入力B" MsgBox "B処理します。" Case "入力C" MsgBox "C処理します。" End Select End Sub どうやったら、Targetに設定されている名前を取得できるのでしょうか？ (^∇^`)？ 実際の例はもっと対象が多いので、Select Caseを使わない以下の方法は避けたいのです。 If文の羅列（これでも正しく作動はします。） Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, Range("入力A,入力B,入力C")) Is Nothing Then Exit Sub If Not Intersect(Target, Range("入力A")) Is Nothing Then MsgBox "A処理します。" ElseIf Not Intersect(Target, Range("入力B")) Is Nothing Then MsgBox "B処理します。" Else MsgBox "C処理します。" End If End Sub なにとぞよろしくお願いします。 (o。_。)oペコッ
- ベストアンサー
- オフィス系ソフト
- Excelのマクロを使用してオートシェイプ図形の色を変えたいのです。
Excelのマクロを使用してオートシェイプ図形の色を変えたいのです。 オートシェイプ図形を５０個ならべて、マウスでクリックしてものは色が変わるようにしたいと思います。 マクロ記録をすると以下のようになりました。 Sub Macro1() ActiveSheet.Shapes("AutoShape 1").Select Selection.ShapeRange.Fill.ForeColor.SchemeColor = 45 Selection.ShapeRange.Fill.Visible = msoTrue Selection.ShapeRange.Fill.Solid End Sub このプログラムを５０個書くわけにはいかないのですが、プログラムで処理するのに問題点が２つ出てきました。 ・オートシェイプ図形の名前が"AutoShape 1"となっていますが、これを変更したいのですが、書式設定にはありませんでした。変更するにはどうすればよいのでしょう？ ・クリックしたオートシェイプ図形がどれであるかを返す関数がないと、どの図形がクリックされたかわからないのですが、これを返す関数はあるのでしょうか？ よろしくお願いします。
- ベストアンサー
- その他MS Office製品