| |
こんばんわ。
マナさんが言ってた案件はこちらですね。
> If Target.Count = 1 Then
に関してはマナさんのアドバイス通りと思います。
> If Application.CutCopyMode Then
こちらの判定部分ですが、セルに貼り付けれるデータでCutCopyMode が有効になるのは、セルを選択した時だけです。
文字を直接選択してコピーした時や、他のアプリからのデータコピーには対応できません。
そう言うデータも禁止にするなら、以下のようにクリップボードの中にデータがあるかを判定した方が良いです。
If Application.ClipboardFormats(1) > -1 Then
ただこちらの案件ではMsgBoxで貼付を選択するようになっているので、消去した時との区別が出来ないので、かなり難しいですね。
多少妥協してもらう部分はありますがIF分岐で考えてみました。
ThisWorkbookモジュールに以下を記述して下さい。
Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
Private Declare Function EmptyClipboard Lib "User32" () As Long
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Ans As Integer, cb As Object, val As String
Application.EnableEvents = False
If Target.Address = Selection.Address Then
If Application.ClipboardFormats(1) > -1 Then
Set cb = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
cb.GetFromClipboard
val = cb.GetText
If (Len(val) = 0 And Application.CutCopyMode = 0) Or _
(Len(val) = 2 And Application.CutCopyMode > 0) Then
Application.Undo
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
Else
If Not IsEmpty(Target.Value) Then
Ans = MsgBox("本当に貼り付けますか？", vbYesNo, "確認")
If Ans = vbNo Then
MsgBox "正しいデータを貼り付けてください"
Application.Undo
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
End If
End If
End If
End If
End If
Application.EnableEvents = True
End Sub
上記コードは値の消去やDelete・BackSpaceなどでは反応しません。
代わりに空白セルや長さ0の文字列をコピーした場合にUndoが働き貼付出来ません。
それと文字選択状態(f2を押した時)での貼付はメッセージも出ず貼付出来てしまいます。
上の2つは消去との区別が出来ませんでした。
|
|
sy
- 16/6/12(日) 3:05 -
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
