ベストアンサー

VBAでオートシェイプの制御？

2004/03/19 11:48

エクセルマクロでセルにオートシェイプを張る方法を調べていて、ここで丁度いいのを見つけました。 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

otasukey
お礼率77% (105/136)

オフィス系ソフト
回答数5
ありがとう数3

みんなの回答 （5）
専門家の回答

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

ベストアンサー

shishishishi
ベストアンサー率39% (362/921)

2004/03/19 13:30 回答No.3

http://oshiete1.goo.ne.jp/kotaeru.php3?q=808898でご質問の回答を書いたものです。あのときの質問ではそこまでの動作のリクエストではなかったので簡単に書いてしまいました。 No1の方から良い回答が出ていますので、それを少しだけいじれば再質問にも対応できるとおもいます。 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 On Error Resume Next ActiveSheet.Shapes("MyHeart").Delete Selection.Name = "MyHeart" Else On Error Resume Next ActiveSheet.Shapes("MyHeart").Delete End If End Sub つまりハートが重ならないように、MyHeartをその都度消してます。無いとエラーになるのでエラーを回避してます。

質問者

補足 2004/03/19 13:46

ありがとうございます。フィルドラッグコピーすると実行エラーになりましたので No2の方の回答をあわせ、 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Or Target.Address(False, False) <> "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 On Error Resume Next ActiveSheet.Shapes("MyHeart").Delete Selection.Name = "MyHeart" Else On Error Resume Next ActiveSheet.Shapes("MyHeart").Delete End If Range("A1").Select End Sub としましたが、これで正解でしょうか？

ログインすると、全ての回答が全文表示されます。

その他の回答 (4)

TTak
ベストアンサー率52% (206/389)

2004/03/19 15:14 回答No.5

一度オートシェイブ作ってあとは表示・非表示という手もありますね。ただ、大量に作るとファイル重くなりますが。(^^;) Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$A$1" Then Exit Sub If Target.Value = 1 Then 　On Error GoTo SHAPEMAKE 　ActiveSheet.Shapes("MyHeart").Visible = True Else 　ActiveSheet.Shapes("MyHeart").Visible = False End If Exit Sub SHAPEMAKE: With ActiveSheet.Range("B1") 　ActiveSheet.Shapes.AddShape(Type:=msoShapeHeart, _ 　　Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height).Name = "MyHeart" End With End Sub

質問者

お礼 2004/03/19 16:42

ありがとうございました。

ログインすると、全ての回答が全文表示されます。

ja7awu
ベストアンサー率62% (292/464)

2004/03/19 14:11 回答No.4

＃２ですが、セルA1に１が入っているのに同じく１を上書きするとハートが２つ重なりますので、これを解消するためには、次のようにした方がいいと思います。 Private Sub Worksheet_Change(ByVal Target As Range) Dim Shp As Shape Set Target = Application.Intersect(Range("A1"), Target) If Target Is Nothing Then Exit Sub If Target.Value = 1 Then 　　For Each Shp In ActiveSheet.Shapes 　　　　If Not Application.Intersect(Shp.TopLeftCell, _ 　　　　　　Range("B2")) Is Nothing Then 　　　　　　Shp.Delete 　　　　End If 　　Next Shp 　　With ActiveSheet.Range("B2") 　　　　ActiveSheet.Shapes.AddShape(Type:=msoShapeHeart, _ 　　　　Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height).Select 　　End With 　　Range("A1").Select 　　SendKeys "{Enter}" Else 　　For Each Shp In ActiveSheet.Shapes 　　　　If Not Application.Intersect(Shp.TopLeftCell, _ 　　　　　　Range("B2")) Is Nothing Then 　　　　　　Shp.Delete 　　　　End If 　　Next Shp End If End Sub

質問者

お礼 2004/03/19 16:42

ありがとうございました。

ログインすると、全ての回答が全文表示されます。

ja7awu
ベストアンサー率62% (292/464)

2004/03/19 13:29 回答No.2

> If Target <> Range("A1") Then Exit Sub ちょっとTargetの使い方が適当でないですね。 Targetは、ActiveCellみたいに１つのセルとは限りません。これですとシート内のセルを何処でもフィルドラッグコピーすると実行エラーになると思いますが・・・　例えば、こんな感じでいかがでしょうか。 Private Sub Worksheet_Change(ByVal Target As Range) Dim Shp As Shape If Target.Count > 1 Or Target.Address(False, False) <> "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 　　Range("A1").Select Else 　　For Each Shp In ActiveSheet.Shapes 　　　　If Not Application.Intersect(Shp.TopLeftCell, Range("B2")) Is Nothing Then 　　　　　　Shp.Delete 　　　　End If 　　Next Shp End If End Sub

質問者

補足 2004/03/19 13:45

ありがとうございます。おっしゃる通りフィルドラッグコピーすると実行エラーになりました。あと、ご教示の例ですと、１を続けるとハートがどんどん増えます。そこでNo3の方の回答をあわせ、 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Or Target.Address(False, False) <> "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 On Error Resume Next ActiveSheet.Shapes("MyHeart").Delete Selection.Name = "MyHeart" Else On Error Resume Next ActiveSheet.Shapes("MyHeart").Delete End If Range("A1").Select End Sub としましたが、これで正解でしょうか？

ログインすると、全ての回答が全文表示されます。

mythism
ベストアンサー率52% (45/86)

2004/03/19 12:47 回答No.1

以下のようにしてみてはいかがでしょうか． 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 Selection.Name = "MyHeart" Else ActiveSheet.Shapes("MyHeart").Delete End If End Sub

質問者