Excel VBAオブジェクト（図形）の保護

質問

Excel VBAのオブジェクト（図形）の保護について質問させて頂きます。

現在、社内の打合せコーナーの予約表をExcel VBAで作成しておりまして、予約したい開始時間に名前、終了時間に＊を入れると、図形の矢印が描画される様になっています。（画像をご参照）
しかし、この矢印が動かせてしまう為、開始時間の名前と終了時間の＊が入っている間は動かせない様にし、名前と＊を消すと矢印が消える様にしたいのですが、どの様にコーディングすれば実現できるでしょうか？

ご存知の方、ご教示宜しくお願い致します。

↓は予約表の現在のVBAのコードです。

Private Sub Worksheet_Change(ByVal Target As Range)

Dim stflg As String
Dim sth As Long
Dim stw As Long
Dim edh As Long
Dim edw As Long

Const maxw = 26
Const maxh = 66
Const cellh = 13.5
Const cellw = 33.85

'入力チェック
With ActiveSheet
For i = 6 To maxh Step 2
stflg = ""
For j = 3 To maxw
If .Cells(i, j).Value <> "" Then
If .Cells(i, j).Value = "*" Then
If stflg = "" Then
MsgBox "入力内容が誤りです"
.Cells(i, j).Select
Exit Sub
Else
stflg = ""
End If
Else
stflg = "1"
End If
End If
Next j
Next i
End With

'矢印を全て削除する
For Each oShape In ActiveSheet.Shapes
If oShape.Type = msoLine Then oShape.Delete
Next

With ActiveSheet

For i = 6 To maxh Step 2
stflg = ""
For j = 3 To maxw
If .Cells(i, j).Value <> "" Then
If .Cells(i, j).Value = "*" Then
edh = ((i - 2) * cellh) + (cellh / 1.6)
edw = 60 + ((j - 2) * cellw)

With .Shapes.AddLine(stw, sth, edw, edh).Line
.ForeColor.SchemeColor = 0
.EndArrowheadStyle = msoArrowheadStealth
.Weight = 1.5
End With
stflg = ""
Else
If stflg = "" Then
sth = ((i - 2) * cellh) + (cellh / 1.6)
stw = 60 + ((j - 3) * cellw)
stflg = "1"
Else
edh = ((i - 2) * cellh) + (cellh / 1.6)
edw = stw + cellw
With .Shapes.AddLine(stw, sth, edw, edh).Line
.ForeColor.SchemeColor = 0
.EndArrowheadStyle = msoArrowheadStealth
.Weight = 1.5
sth = ((i - 2) * cellh) + (cellh / 1.6)
stw = 60 + ((j - 3) * cellw)
End With

End If
End If
End If
If j = maxw And stflg <> "" Then
edh = ((i - 2) * cellh) + (cellh / 1.6)
edw = stw + cellw
With .Shapes.AddLine(stw, sth, edw, edh).Line
.ForeColor.SchemeColor = 0
.EndArrowheadStyle = msoArrowheadStealth
.Weight = 1.5
End With
End If

Next j

Next i

End With

End Sub

回答No.1

mitarashi · ベストアンサー

もう見ていないかな？
アイデアの提示だけではなんなので、自分なりのコードで試してみました。

偶数行に、値を入れ、次いで右方のセルに「*」を入れると、一つ上の行に矢印を引きます。
このときOnActionでマクロを仕込んでおきます。
引いた矢印は保護が掛けられて消せません。（簡便のためセルのデータの保護等は考慮していません）
矢印下のスタート位置のセルの値と、終了位置の「*」を消した後、矢印をクリックすると、仕込んで置いたマクロが動いて保護が外れます。下記コードではついでに消してしまっています。
ご希望の仕様と異なりますが、複雑なイベントマクロを読み解いて、更に複雑な動作を組み込む元気がありませんので、参考になる部分があればご活用下さい。（Changeイベントで全図形をスキャンして、TopLeftCell,BottomRightCellの合致をみて図形を特定し、保護を外して削除するといった事は可能と思います）

'☆シートモジュール
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Dim myColumn As Long
Dim startCell As Range
Dim myShape As Shape

If Target.Cells.Count > 1 Then Exit Sub
If (Target.Row Mod 2) > 0 Then Exit Sub
If Target.Value <> "*" Then Exit Sub
For i = 1 To Target.Column - 1
If Target.Offset(, -1 * i).Value <> "" And Target.Offset(, i).Value <> "*" Then
Set startCell = Target.Offset(, -1 * i)
Exit For
End If
Next i
Me.Unprotect
If Not startCell Is Nothing Then
Set myShape = Me.Shapes.AddLine(startCell.Left, startCell.Top - startCell.Height / 2, Target.Left + Target.Width, Target.Top - startCell.Height / 2) '.Line
myShape.OnAction = "shapeUnprotect"
With myShape.Line
.ForeColor.SchemeColor = 0
.EndArrowheadStyle = msoArrowheadStealth
.Weight = 1.5
End With
End If
Me.Protect DrawingObjects:=True
End Sub

'☆標準モジュール
Sub shapeUnprotect()
Dim myShape As Shape
Set myShape = ActiveSheet.Shapes(Application.Caller)
'なぜかBottomRightCellは矢印を引いた最終セルの一つ右のセルになっているので-1している
If myShape.TopLeftCell.Offset(1, 0).Value = "" And myShape.BottomRightCell.Offset(1, -1).Value = "" Then
ActiveSheet.Shapes(Application.Caller).Locked = msoFalse
'ついでに消してしまう場合
ActiveSheet.Shapes(Application.Caller).Delete
End If
End Sub

お礼

返信が遅くなりまして申し訳ございません。

ご回答有難うございます！
ご丁寧にアイディアをご提示下さいまして、感謝致しております。

是非ご参考にさせて頂きたいと思います！