ダブルクリックで貼付け確認のイベントを発生させたい

質問

E１セルをダブルクリックすると、「コピーしたテキストを貼り付けますか？」という
質問のポップがでてきて、”はい”を押すと、勝手に値のみの形式で貼り付けられ
、”いいえ”を押すと何も起こらないようにしたいです。そして、貼り付けるテキスト
がない場合は、ダブルクリックをすると逆に、「コピーしたテキストがありません」と
いう忠告がでてきて、OKで忠告ポップを終わらせるようにしたいです。どのようなコード
を書けばよいかお力をいただければ幸いです(´；ω；｀)。。

回答No.4

keithin · ベストアンサー

ふむ。。。

準備：
ＶＢＥ画面を開き、ツールメニューの参照設定で
Microsoft Forms 2.0 Object Library
にチェックする

シートモジュールに下記をコピー貼り付ける

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, cancel As Boolean)
　Dim d As MSForms.DataObject
　Dim res
　Set d = New MSForms.DataObject
　If Application.Intersect(Target, Range("E1")) Is Nothing Then Exit Sub
　cancel = True

　d.GetFromClipboard
　On Error GoTo errhandle
　res = Application.Clean(d.GetText)
　If MsgBox("paste?", vbOKCancel) = vbOK Then
　Target = res
　End If
　Exit Sub

errhandle:
　MsgBox "nothing"
End Sub

Ｅ１でＷクリックする。

＃補足
たとえばＥＳＣキーを押すとかでは、「貼り付けるものが無い」状態を作れないので注意してください

お礼

ご回答ありがとうございますm(__)m
d As MSForms.DataObjectの所が選択されて、コンパイルエラー：ユーザ定義型は定義されていませんというエラーがでてしまいました(´；ω；｀)
参照設定でMicrosoft Forms 2.0 Object Libraryにチェックは確かに入っています。
いつも本当に申し訳ないです。。

補足

度々申し訳ないです；[挿入]－[ユーザーフォーム]-[UserForm]を追加。
[ツール]-[参照設定]-[Microsoft Forms 2.0 Object Library]にチェックがついている事を確認したら、
できました！　自宅のPCなのでよかったです。職場でできるか不安ですが頑張ってみます！！
もしできなかったら怖いのでこの質問はあと少しだけ置かせて下さい(´；ω；｀)
keithinさんありがとうございますm(__)mm(__)m

回答No.5

watabe007

>例えばセルに　パソコンがあります　と書いていた時に、
>がありますだけコピーしたような感じです。そういう時は、上記の失敗が表示される
こんな事かな？
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean)
　　Dim CB As Variant, i As Long
　　Dim myFlg As Boolean
　　If Target.Address <> "$E$1" Then Exit Sub
　　cancel = True
　　CB = Application.ClipboardFormats
　　For i = 1 To UBound(CB)
　　　　If CB(i) = xlClipboardFormatText Then
　　　　　　myFlg = True
　　　　　　Exit For
　　　　End If
　　Next i
　　If myFlg <> True Then
　　　　MsgBox "コピーしたテキストがありません", 48
　　　　Exit Sub
　　End If
　　If MsgBox("コピーしたテキストを貼り付けますか？", vbYesNo + vbQuestion) = vbYes Then
　　　　On Error Resume Next
　　　　ActiveSheet.PasteSpecial Format:="テキスト"
　　　　If Err Then Selection.PasteSpecial Paste:=xlValues
　　　　On Error GoTo 0
　　End If
End Sub

お礼

何度もご回答ありがとうございますm(_ _)m
希望の趣旨のものになっています！
ただ、ただ、申し訳ないです。。(´；ω；｀)
例えばセル内でEnterで改行されたものをコピーしていた場合は一つずれて
貼付けられます；あとメモ帳で改行したもののコピーや空白後改行したものを
コピーしても失敗するようです；そこまで想定していなかったと思うので申し訳
なかったです。。

回答No.3

watabe007

>E１セルをダブルクリックすると
訂正してください
If Target.Address <> "$E$4" Then Exit Sub
↓
If Target.Address <> "$E$1" Then Exit Sub

お礼

ご回答ありがとうございます；
実際にやってみますと、貼り付けるものが無いときは、OKで終了できました。ただ、貼付けるものがあるときに、はいをおすと
実行時エラー　Range　クラスの　PasteSpecial メソッドが失敗しました　というポップがでます；

補足

度々申し訳ないです；セルそのものをコピーしてやれば成功しました！
しかし質問が十分で申し訳ございません；コピーはテキストを選んでコピーした
ものを指します；　例えばセルに　パソコンがあります　と書いていた時に、
がありますだけコピーしたような感じです。そういう時は、上記の失敗が表示される
みたいです；

回答No.2

okormazd

E１セルだけにしか対応していないので、ほかのセルやセル範囲にするには変更する。
操作したいセルのあるSheetのコードモジュールに置く。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
If Target.Address = "$E$1" Then
If Application.CutCopyMode Then
res = MsgBox("コピーしたテキストを貼り付けますか？", vbOKCancel)
If res = vbOK Then
Target.PasteSpecial Paste:=xlPasteValues
End If
Else
res = MsgBox("コピーしたテキストがありません", vbOKOnly)
End If
End If
End Sub

お礼

ごかいとうありがとうございます。何かコピーしていても、常にコピーしたテキストがありませんと表示されます；

補足

度々失礼します；セル自体をコピーしていれば成功しました！ありがとうございますm(__)m
ただ、今回の私の質問が不十分だったため重ねておわび申し上げます；　貼り付けたいものはセルそのものではなくて、例えばセルの中の文字の一部分のみを選択してコピー等をしたテキストを指します。そういうものはテキストとして表示されないのでしょうか？(´；ω；｀)

回答No.1

watabe007

参考に
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
　　Dim CB As Variant, i As Long
　　Dim myFlg As Boolean

　　If Target.Address <> "$E$4" Then Exit Sub
　　Cancel = True
　　CB = Application.ClipboardFormats
　　For i = 1 To UBound(CB)
　　　　If CB(i) = xlClipboardFormatText Then
　　　　　　myFlg = True
　　　　　　Exit For
　　　　End If
　　Next i
　　If myFlg <> True Then
　　　　MsgBox "コピーしたテキストがありません", 48
　　　　Exit Sub
　　End If
　　If MsgBox("コピーしたテキストを貼り付けますか？", vbYesNo + vbQuestion) = vbYes Then
　　　　Selection.PasteSpecial Paste:=xlValues
　　End If
End Sub

お礼

お早いご回答本当にありがとうございますm(_ _)m
If Target.Address <> "$E$4" Then Exit Sub
↓
If Target.Address <> "$E$1" Then Exit Sub

修正してみました。しかし上のお礼のような形になってしまいました(´；ω；｀)