Excel电子表格VBA代码始终不工作

我正在处理的excel电子表格上运行的代码运行良好，当我将信息复制并导入受保护的单元格时，会出现类型不匹配错误，并且无法确定如何修复代码

    Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Whoa

    Application.EnableEvents = False

    If Not Intersect(Target, Range("C1:C20")) Is Nothing Then
        If Len(Trim(Target.Value)) = 0 Then Application.Undo
    End If

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

---

您的工作表必须受到保护，因此您需要先解除工作表的保护：

  Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Sheets("NameOfYourSheet").Unprotect Password:="YourPassWord" ' Change the name of the sheet which is locked
    On Error GoTo Whoa

    Application.EnableEvents = False

    If Not Intersect(Target, Range("C1:C20")) Is Nothing Then
        If Len(Trim(Target.Value)) = 0 Then Application.Undo
    End If

Sheets("NameOfYourSheet").Protect Password:="YourPassWord" 

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

---

您的工作表必须受到保护，因此您需要先解除工作表的保护：

  Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Sheets("NameOfYourSheet").Unprotect Password:="YourPassWord" ' Change the name of the sheet which is locked
    On Error GoTo Whoa

    Application.EnableEvents = False

    If Not Intersect(Target, Range("C1:C20")) Is Nothing Then
        If Len(Trim(Target.Value)) = 0 Then Application.Undo
    End If

Sheets("NameOfYourSheet").Protect Password:="YourPassWord" 

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

---

将多个值粘贴到C1:C20范围内的两个或多个单元格中时，目标值大于1，并且不能使用目标值

通常，您会使用如下内容

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Range("C1:C20")) Is Nothing Then
        'do not do anything until you know you are going to need it
        On Error GoTo Whoa
        Application.EnableEvents = False
        Dim crng As Range

        'in the event of a paste, Target may be multiple cells
        'deal with each changed cell individually
        For Each crng In Intersect(Target, Range("C1:C20"))
            If Len(Trim(crng.Value)) = 0 Then Application.Undo
            'the above undoes all of the changes; not just the indivual cell with a zero
        Next crng
    End If

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

但是，您希望使用

应用程序.Undo

会出现一些独特的问题，因为您不想撤消所有更改；只有那些结果为零的。这里有一个可能的解决办法

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Range("C1:C20")) Is Nothing Then
        'do not do anything until you know you are going to need it
        On Error GoTo Whoa
        Application.EnableEvents = False
        Dim c As Long, crng As Range, vals As Variant, prevals As Variant
        'store the current values
        vals = Range("C1:C20").Value2
        'get the pre-change values back
        Application.Undo
        prevals = Range("C1:C20").Value2

        'in the event of a paste, Target may be multiple cells
        'deal with each changed cell individually
        For c = LBound(vals, 1) To UBound(vals, 1)
            If vals(c, 1) = 0 Then vals(c, 1) = prevals(c, 1)
        Next c
        Range("C1:C20") = vals
    End If

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

---

新值存储在变量数组中，然后取消粘贴。旧值存储在另一个变量数组中。将遍历新值，如果出现零，则将其替换为旧值。最后，修改后的新值集将粘贴回C1:C20范围。

当您将多个值粘贴到C1:C20范围内的两个或多个单元格中时，目标值大于1，并且您不能使用目标值

通常，您会使用如下内容

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Range("C1:C20")) Is Nothing Then
        'do not do anything until you know you are going to need it
        On Error GoTo Whoa
        Application.EnableEvents = False
        Dim crng As Range

        'in the event of a paste, Target may be multiple cells
        'deal with each changed cell individually
        For Each crng In Intersect(Target, Range("C1:C20"))
            If Len(Trim(crng.Value)) = 0 Then Application.Undo
            'the above undoes all of the changes; not just the indivual cell with a zero
        Next crng
    End If

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

但是，您希望使用

应用程序.Undo

会出现一些独特的问题，因为您不想撤消所有更改；只有那些结果为零的。这里有一个可能的解决办法

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Range("C1:C20")) Is Nothing Then
        'do not do anything until you know you are going to need it
        On Error GoTo Whoa
        Application.EnableEvents = False
        Dim c As Long, crng As Range, vals As Variant, prevals As Variant
        'store the current values
        vals = Range("C1:C20").Value2
        'get the pre-change values back
        Application.Undo
        prevals = Range("C1:C20").Value2

        'in the event of a paste, Target may be multiple cells
        'deal with each changed cell individually
        For c = LBound(vals, 1) To UBound(vals, 1)
            If vals(c, 1) = 0 Then vals(c, 1) = prevals(c, 1)
        Next c
        Range("C1:C20") = vals
    End If

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

---

新值存储在变量数组中，然后取消粘贴。旧值存储在另一个变量数组中。将遍历新值，如果出现零，则将其替换为旧值。最后，修改后的一组新值被粘贴回C1:C20范围。

谢谢这真的很有帮助，但有一件事没有发生，那就是在指定的范围内，我需要能够复制和插入。因此，如果我有C1:C20，并且所有20个都已填充，我需要能够复制并插入到20中，那么我将有21个，依此类推。这个新要求不在你的问题中。我建议你关闭这个问题，开始另一个问题，以免这成为一个。谢谢这真的很有帮助，但有一件事是没有发生的是，在指定的范围内，我需要能够复制和插入。因此，如果我有C1:C20，并且所有20个都已填充，我需要能够复制并插入到20中，那么我将有21个，依此类推。这个新要求不在你的问题中。我建议你结束这个问题，开始另一个问题，以免这成为一个问题。