Question

我使用的代码来自：http://www.siddharthrout.com/2011/08/15/vba-excelallow-paste-special-only/

我现在唯一的问题是它不允许我从代码所适用的工作表中剪切和粘贴。希望有人对如何让它发挥作用我有一个很棒的想法。已经做了很多测试，改变了cutcopymode和其他一些愚蠢的想法，但没有运气。

这是一张允许用户在10列和3000行范围内自由移动，切割，自动填充，复制数据的工作表。他们还需要能够从其他Excel工作表复制/剪切到工作表和工作簿。因此，用户必须被赋予ctrl + x ctrl + v以及右键单击和剪切/粘贴以及excel中可用于剪切和粘贴的所有其他方法。下面的代码是我发现的唯一一个没有覆盖keyboardshortcuts和gui对象的方法。

代码：

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim UndoList As String

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    On Error GoTo Whoa

    '~~> Get the undo List to capture the last action performed by user
    UndoList = Application.CommandBars("Standard").Controls("&Undo").List(1)

    '~~> Check if the last action was not a paste nor an autofill
    If Left(UndoList, 5) <> "Paste" And UndoList <> "Auto Fill" _
    Then GoTo LetsContinue

    '~~> Undo the paste that the user did but we are not clearing the 
    '~~> clipboard so the copied data is still in memory
    Application.Undo

    If UndoList = "Auto Fill" Then Selection.Copy

    '~~> Do a pastespecial to preserve formats
    On Error Resume Next
    '~~> Handle text data copied from a website
    Target.Select
    ActiveSheet.PasteSpecial Format:="Text", Link:=False, _
    DisplayAsIcon:=False

    Target.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
    On Error GoTo 0

    '~~> Retain selection of the pasted data
    Union(Target, Selection).Select

LetsContinue:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Exit Sub
Whoa:
    MsgBox Err.description
    Resume LetsContinue
End Sub

Excel VBA始终仅粘贴值

0 个答案: