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

回答No.3

shishishishi · ベストアンサー

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をその都度消してます。無いとエラーになるのでエラーを回避してます。

補足

ありがとうございます。
フィルドラッグコピーすると実行エラーになりましたので
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

としましたが、これで正解でしょうか？

回答No.5

TTak

一度オートシェイブ作ってあとは表示・非表示という手もありますね。ただ、大量に作るとファイル重くなりますが。(^^;)

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

お礼

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

回答No.4

ja7awu

＃２ですが、セル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

お礼

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

回答No.2

ja7awu

> 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

補足

ありがとうございます。
おっしゃる通りフィルドラッグコピーすると実行エラーになりました。
あと、ご教示の例ですと、１を続けるとハートがどんどん増えます。
そこで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

としましたが、これで正解でしょうか？

回答No.1

mythism

以下のようにしてみてはいかがでしょうか．

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

お礼

さっそくありがとうございました。
なるほど、名前を付けて、その名前のオートシェイプを削除するわけですね。

やってみました。
うまくいきます。しかし、連続して１を入れるとどんどんハートが重なりますし、連続して1以外だと、重なったハート無くなればエラーになります。

どうすればいいでしょうか？