| |
▼じょにー さん：
こちらで継続されるということになったようで...
それならそれで構いませんが、後々のため、元スレはそのむね明記して
閉じておいたほうがよろしいかと。
コード拝見させていただきました。
それに沿って、各プロシージャについて、こんな風に変更したらどうか
という修正案を下記に示します。
'--- Sheet1 モジュール ---
Option Explicit
Private Sub Worksheet_BeforeDoubleClick( _
ByVal Target As Range, Cancel As Boolean)
Dim sh As Shape
Dim c As Long
Cancel = True
For Each sh In ActiveSheet.Shapes
If Not Application.Intersect(Target, sh.TopLeftCell) Is Nothing Then
Call Module1.DelShape(sh.Name) 'その名前のShapeを消す
Exit Sub
End If
Next sh
Call Module1.AddShape(Target)
End Sub
'--- Module1 ---
Option Explicit
Public Sub AddShape(Target As Range)
With Target
.HorizontalAlignment = xlCenter
With ActiveSheet.Shapes.AddShape(msoShapeDonut, _
.Left, .Top, .Width, .Height)
.Fill.Transparency = 0#
.Line.ForeColor.SchemeColor = 64
.Line.BackColor.RGB = RGB(255, 255, 255)
.Select
End With
End With
End Sub
Public Sub DelShape(ShpName As String)
ActiveSheet.DrawingObjects(ShpName).Delete
End Sub
|
|
kanabun
- 11/10/9(日) 19:35 -
