excel - 复制或剪切时强制粘贴值以避免格式或数据验证更改(包括外部数据)

Question

我正在构建一个工作簿供其他人输入数据，但我需要它们不要干扰格式或验证。我在网上查了很多资料并想出了一个好方法(恕我直言)。我正在使用 Worksheet_Change 子程序来检查输入数据是否被复制、剪切或直接写入单元格中。我遇到的问题是，它在复制时效果很好，但是当它被剪切并到达“退出子”部分时，它会回到程序的开头重新进行。我猜想当我退出子进程时 Worksheet_Change 事件会再次触发，但我不明白为什么会发生这种情况。

这是我的主要问题。第二个问题是，如果文本已写入(未复制或剪切)，我想重做写入(Windows 上的 ctrl Y 或 mac 上的 cmd Y)，但我有一台 Mac，不知道如何引用“命令”按钮。

这是代码。由于我来自阿根廷，注释是西类牙语。预先感谢您的帮助!

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim aCell As Range
    Dim CeldasNoValidadas As String
    
    On Error GoTo Whoa

    CeldasNoValidadas = " "
        
    Application.EnableEvents = False
    
    Application.Undo
    
    'Si se puso Copiar, pega valores
    If Application.CutCopyMode = xlCopy Then
        Target.PasteSpecial Paste:=xlPasteValues
    Else
        'Si se puso cortar avisa que no se puede y sale.
        If Application.CutCopyMode = xlCut Then
            MsgBox "No se puede pegar contenido que se haya cortado. Copie el contenido para pegarlo en esta celda.", , """Cortar"" no esta permitido"
            Application.EnableEvents = True
            Exit Sub
        Else
            'Si no puso cortar ni copiar, repite la accion que se deshizo.
            Application.SendKeys ("^y")
        End If
    End If

    'Chequea que cada celda cumpla con la validacion
    For Each aCell In Target.Cells
        If Not aCell.Validation.Value Then
            'Si la celda no es valida la borra y la suma a la lista de celdas no validas
            CeldasNoValidadas = CeldasNoValidadas & ", " & aCell.Address(RowAbsolute:=False, ColumnAbsolute:=False)
            aCell.ClearContents
        End If
    Next

    'Si alguna celda no cumple la validacion, muestra un mensaje con la lista de celdas no validas
    If Len(CeldasNoValidadas) > 1 Then
       MsgBox "Las siguientes celdas no tienen contenido valido y fueron borradas: " & Right(CeldasNoValidadas, Len(CeldasNoValidadas) - 3), , "Celdas no validas"
    End If

        Application.EnableEvents = True
        Exit Sub

Letscontinue:
        Application.EnableEvents = True
        Exit Sub
Whoa:
        MsgBox Err.Description
        Resume Letscontinue


End Sub

Answer 1

您可以结合使用 SelectionChange 和 Change 事件处理程序来简化代码并处理这两个问题，如下所示:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim aCell As Range
    Dim CeldasNoValidadas As String

    On Error GoTo Whoa

    CeldasNoValidadas = " "

    Application.EnableEvents = False

    'Si se puso Copiar, pega valores
    If Application.CutCopyMode = xlCopy Then
        Application.Undo
        Target.PasteSpecial Paste:=xlPasteValues
    End If

    'Chequea que cada celda cumpla con la validacion
    For Each aCell In Target.Cells
        If Not aCell.Validation.Value Then
            'Si la celda no es valida la borra y la suma a la lista de celdas no validas
            CeldasNoValidadas = CeldasNoValidadas & ", " & aCell.Address(RowAbsolute:=False, ColumnAbsolute:=False)
            aCell.ClearContents
        End If
    Next

    'Si alguna celda no cumple la validacion, muestra un mensaje con la lista de celdas no validas
    If Len(CeldasNoValidadas) > 1 Then
       MsgBox "Las siguientes celdas no tienen contenido valido y fueron borradas: " & Right(CeldasNoValidadas, Len(CeldasNoValidadas) - 3), , "Celdas no validas"
    End If

Letscontinue:
        Application.EnableEvents = True
        Exit Sub
Whoa:
        MsgBox Err.Description
        Resume Letscontinue


End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Application.CutCopyMode = xlCut Then
        Application.CutCopyMode = False
        MsgBox "No se puede pegar contenido que se haya cortado. Copie el contenido para pegarlo en esta celda.", , """Cortar"" no esta permitido"
    End If
End Sub

这样当且仅当用户正在复制单元格时才可以撤消。因此，您永远不需要重做(即不需要 SendKeys，应尽可能避免)

注1:为什么剪切/粘贴会触发Change事件两次？在底层，剪切/粘贴操作是复制/粘贴和删除操作的组合，这两个操作都会触发 Change 事件处理程序。

注2:上述解决方案不会阻止用户从其他应用程序(例如word和互联网浏览器)复制内容。它也不会阻止它们自动填充。您可以检查“撤消”列表来计算出最后一个操作( have a look at this )。如果最后一个操作是粘贴并且 CutCopyMode 为 false，则内容很可能是从另一个应用程序复制的。要处理这种情况，您可以执行以下操作(这绝不是详尽的):

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim aCell As Range
    Dim CeldasNoValidadas As String
    Dim undoAction As String

    On Error GoTo Whoa

    CeldasNoValidadas = " "

    Application.EnableEvents = False

    'Si se puso Copiar, pega valores
    If Application.CutCopyMode = xlCopy Then
        Application.Undo
        Target.PasteSpecial Paste:=xlPasteValues
    Else
        '* Get the last action from the undo list
        undoAction = Application.CommandBars("Standard").Controls("&Undo").List(1)
        
        '* A paste here means contents were copied from outside the application
        If Left(undoAction, 5) = "Paste" Then
            '* If not pasting images (from the internet - html) then remove formatting
            '* Remove the condition if you do not want to allow pasting images from the internet
            If MsgBox("Are you pasting an image?", vbYesNo + vbDefaultButton2) <> vbYes Then
                Application.Undo
                Me.PasteSpecial Format:="HTML", DisplayAsIcon:=False, Link:=False, NoHTMLFormatting:=True
            End If
        ElseIf undoAction = "Auto Fill" Then
            Application.Undo
            MsgBox "Auto fill not allowed, please try copying"
        End If
    End If

    'Chequea que cada celda cumpla con la validacion
    For Each aCell In Target.Cells
        If Not aCell.Validation.Value Then
            'Si la celda no es valida la borra y la suma a la lista de celdas no validas
            CeldasNoValidadas = CeldasNoValidadas & ", " & aCell.Address(RowAbsolute:=False, ColumnAbsolute:=False)
            aCell.ClearContents
        End If
    Next

    'Si alguna celda no cumple la validacion, muestra un mensaje con la lista de celdas no validas
    If Len(CeldasNoValidadas) > 1 Then
       MsgBox "Las siguientes celdas no tienen contenido valido y fueron borradas: " & Right(CeldasNoValidadas, Len(CeldasNoValidadas) - 3), , "Celdas no validas"
    End If

Letscontinue:
        Application.EnableEvents = True
        Exit Sub
Whoa:
        MsgBox Err.Description
        Resume Letscontinue


End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Application.CutCopyMode = xlCut Then
        Application.CutCopyMode = False
        MsgBox "No se puede pegar contenido que se haya cortado. Copie el contenido para pegarlo en esta celda.", , """Cortar"" no esta permitido"
    End If
End Sub