セルのコピーペースト

質問

ある人が、シート「Sheet1」のセルA1をコピーして
セルB1にペーストしました。

この操作をされたことを知る方法ってありますか？

やりたいことは、セルがペーストされたときに
「A1のセルがB1のセルにコピーペーストされたました。」
とメッセージを表示したいと思っています。

回答No.3

Wendy02 · ベストアンサー

'前回の続き
'---
'クラス(Class1)
Private WithEvents NewBtn As Office.CommandBarButton

Public Property Set myNewBtn(ByVal myBtn As CommandBarButton)
　Set NewBtn = myBtn
End Property

Private Sub NewBtn_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
　Dim sRng As String
　Dim msg As String
　On Error Resume Next
　If IsClipboardFormatAvailable(CF_TEXT) = 0 Then Exit Sub
　If ActiveSheet.ProtectContents Then
　　MsgBox "セルは保護されています。", vbExclamation
　　Exit Sub
　End If
　If ActiveSheet.ProtectContents Then
　　If ActiveCell.Locked = False Then
　　　msg = vbCrLf & "しかし、セルに入力可能です。"
　　Else
　　　msg = ""
　　End If
　　MsgBox "セルは保護されています。" & msg, vbExclamation
　　Exit Sub
　End If

　If TypeName(Selection) = "Range" Then
　　sRng = Selection.Address(0, 0)
　　sRng = sRng & "に"
　Else
　　Exit Sub
　End If
　Selection.PasteSpecial
　On Error GoTo 0
　CancelDefault = False
　'二重呼び出しの禁止
　If Pastechk = False Then
　　MessageBoxTimeoutA 0&, sRng & "貼り付けされました。", "貼り付け", vbMsgBoxSetForeground, 0, 2000
　　Pastechk = True
　Else
　　Pastechk = False
　End If
End Sub

'-------
変更点：

・セルをコピーして、貼り付けしないと、メッセージが出ないようにしました。ただ、もう少し改良点が残されています。クリップボードの中を検索する必要があります。

・シート保護されている時には、メッセージが出ます。ただし、アクティブセル自体に書き込み可能な時は、そのセルが入力可能であることを明示するようにしました。

注意点：
・クラスオフジェクトは、現段階では、Excelを終了しないと設定が外れません。ただし、NewBtnSettingの部分で、クラスでボタンのインスンタンスを設ける時に、Nothingなどで設定し直せば、外れるはずです。（未確認）

・こちらの発見した誤動作としては、別の設定したクラスとぶつかると、貼り付けがきかなくなる現象を確認しました。ふつうはありえないことですが、今回のマクロは、PERSONAL.XLSなどの起動用に設定されるところに入れてあげれば問題は減ります。新しくブックを設けても同じように動作します。

・現段階では、Ctrl + Z で、Undo が利きません。一般的にはマクロでは出来ないと言われますが、前の状態に戻すことは可能なはずです。（未確認）

「未確認」部分は、再び、どこかで聞いていただければ、このマクロ全体を公開しなくても、解答可能なはずです。以前、やったことのあるテクニックですが、すぐに思い出せません。

お礼

「元に戻す」は機能しないようですね。
それでも、十分すぎるくらいの動作です。

本当にすごいです。
ありがとうございました。

回答No.2

Wendy02

>すごいです。正常に動作確認できました。
最近、OkWaveでは、こういうコードを書くだけで、無視されるケースが多いからです。だから、質問者さんが直接に答えなくてもよいと、#1では、かなり、なげやりな書き方をしてしまいました。失礼な書き方ですみませんでした。

さて、

>シート保護やロックがかかっているセルに貼り付けようとした場合には
>「セルは保護されています」とメッセージを出し、値を貼り付けれない
直しましたが、まだまだ、本当は、改良点が残されています。変更点と改良点は、次の書き込みの最後に書きます。

'標準モジュール
Private ClassBtns(1) As New Class1
Public Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
Public Declare Function MessageBoxTimeoutA Lib "user32" (ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal uType As Long, ByVal wLanguageId As Long, ByVal dwMilliseconds As Long) As Long
Public Pastechk As Boolean
Public Const CF_TEXT As Long = 1&
Public Const CF_BITMAP As Long = 2& '予備
Public Const CF_METAFILEPICT As Long = 3& '予備

Sub Auto_Open()
　Call NewBtnSetting
End Sub

Sub NewBtnSetting()
　With Application
　Set ClassBtns(0).myNewBtn = .CommandBars("Worksheet Menu Bar").Controls("編集(&E)").Controls("貼り付け(&P)")
　Set ClassBtns(1).myNewBtn = .CommandBars("Cell").FindControl(, 22)
　　 .OnKey "^v", "MsgMacro"
　End With
End Sub

Sub MsgMacro()
Dim sRng As String
Dim msg As String
　 On Error Resume Next
　 If IsClipboardFormatAvailable(CF_TEXT) = 0 Then Exit Sub
　 If ActiveSheet.ProtectContents Then
　　　If ActiveCell.Locked = False Then
　　　　 msg = vbCrLf & "しかし、セルに入力可能です。"
　　　Else
　　　　 msg = ""
　　　End If
　　　MsgBox "セルは保護されています。" & msg, vbExclamation
　　　Exit Sub
　 End If
　 If TypeName(Selection) = "Range" Then
　　　sRng = Selection.Address(0, 0)
　　　sRng = sRng & "に"
　 Else
　　 Exit Sub
　 End If
　 Selection.PasteSpecial
　 On Error GoTo 0
　 MessageBoxTimeoutA 0&, sRng & "貼り付けされました。", "貼り付け", vbMsgBoxSetForeground, 0, 2000
End Sub

'次に続く

回答No.1

Wendy02

細かな説明はしません。なぜかというと、「タスク」としてのご質問内容ではないからです。他にも方法がありますが、Win32APIで処理するか、クラスで処理するか、いずれにしても、キーを監視するか、コマンドを監視するか、どちらかだと思います。

「A1のセルがB1のセルにコピーペーストされたました。」 どこから持ってきて、ということは、その経緯を記録しなければなりませんから、倍のコードになります。また、他のクリップボードからの貼付けもあるからです面倒ですから、割愛しました。
[形式を選択して貼り付け]や、[セル以外への貼り付け]には可動しません。

なお、マクロは、Excel 2003 まです。それ以上では可動しません。

'標準モジュール
Private ClassBtns(1) As New Class1
Public Declare Function MessageBoxTimeoutA Lib "user32" (ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal uType As Long, ByVal wLanguageId As Long, ByVal dwMilliseconds As Long) As Long
Public Pastechk As Boolean

Sub Auto_Open()
　Call NewBtnSetting
End Sub

Sub NewBtnSetting()
　With Application
　Set ClassBtns(0).myNewBtn = .CommandBars("Worksheet Menu Bar").Controls("編集(&E)").Controls("貼り付け(&P)")
　Set ClassBtns(1).myNewBtn = .CommandBars("Cell").FindControl(, 22)
　　 .OnKey "^v", "MsgMacro"
　End With
End Sub

Sub MsgMacro()
Dim sRng As String
　 On Error Resume Next
　 If TypeName(Selection) = "Range" Then
　　　sRng = Selection.Address(0, 0)
　　　sRng = sRng & "に"
　 Else
　　 Exit Sub
　 End If
　 Selection.PasteSpecial
　 On Error GoTo 0
　 MessageBoxTimeoutA 0&, sRng & "貼り付けされました。", "貼り付け", vbMsgBoxSetForeground, 0, 2000
End Sub

----
'Class モジュール (Class1)
Private WithEvents NewBtn As Office.CommandBarButton

Public Property Set myNewBtn(ByVal myBtn As CommandBarButton)
　Set NewBtn = myBtn
End Property

Private Sub NewBtn_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
Dim sRng As String
　On Error Resume Next
　 If TypeName(Selection) = "Range" Then
　　 sRng = Selection.Address(0, 0)
　　 sRng = sRng & "に"
　 Else
　　 Exit Sub
　 End If
　 Selection.PasteSpecial
　On Error GoTo 0
　CancelDefault = False
　'二重呼び出しの禁止
　If Pastechk = False Then
　　MessageBoxTimeoutA 0&, sRng & "貼り付けされました。", "貼り付け", vbMsgBoxSetForeground, 0, 2000
　　Pastechk = True
　Else
　　Pastechk = False
　End If
End Sub

お礼

すごいです。正常に動作確認できました。

ただ、シートが保護されている場合や、セルがロックされている場合は
貼り付けれないようにしたいのですが・・・

シート保護やロックがかかっているセルに貼り付けようとした場合には
「セルは保護されています」とメッセージを出し、値を貼り付けれない
ようにするのは無理でしょうか？