如何捕获VBA中所有工作表的粘贴事件？

有人可以帮助我与下面的代码我试图捕获粘贴事件来获取粘贴的select，以删除空间和非打印字符。 所以基本上，当我粘贴我需要它来自动检查，如果我粘贴，并删除任何空间和粘贴select不可打印的字符，这将减less我的macros将处理的时间，因为会有一些给定的时间粘贴行，它对我来说，在这种状态下删除空格和不可打印的字符是合乎逻辑的，而列表很小，不会造成太多的延迟。 它撞在我身上，不能把我的头靠近它。

像往常一样，任何帮助将不胜感激。

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim lastAction As String 'On Error Resume Next ' Get the last action performed by user lastAction = Application.CommandBars("Standard").Controls("&Undo") Debug.Print lastAction ' Check if the last action was a paste If Left(lastAction, 5) = "Paste" Then Call removeSpace End If End Sub Private Sub removeSpace() Dim rngremovespace As Range Dim CellChecker As Range Dim rng As Range 'Set the range Set rngremovespace = Selection 'Application.ScreenUpdating = False 'This check to see if there are any non printing characters and replace them rngremovespace.Select rngremovespace.Columns.Replace What:=Chr(160), Replacement:=Chr(32), _ LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False 'In case of any error skip On Error Resume Next 'Looping through a range that is resizing For Each CellChecker In rngremovespace.Columns 'This will clear all space in the cells CellChecker.Value = Application.Trim(CellChecker.Value) CellChecker.Value = Application.WorksheetFunction.Clean(CellChecker.Value) 'Looping to the next CellChecker Next CellChecker On Error GoTo 0 ' Application.ScreenUpdating = True Set rngremovespace = Nothing End Sub 

Answer 1

需要检查撤销列表是否为空，循环而不是列的单元格，并禁用事件（未testing）：

 Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) With Application.CommandBars("Standard").Controls("&Undo") If .ListCount < 1 Then Exit Sub If .List(1) <> "Paste" Then Exit Sub End With Application.CutCopyMode = False Application.EnableEvents = False Selection.Replace ChrW(160), " ", xlPart Dim cell As Range For Each cell In Selection cell.Value2 = WorksheetFunction.Trim(WorksheetFunction.Clean(cell.Value2)) Next Application.EnableEvents = True End Sub