如何防止运行时错误13：类型不匹配？

Question

我有一个宏，它将使用值或基于下拉选择的黄色填充多个列。例如，下拉列表包含两个项目，＆＃34; YES＆＃34;并且＆＃34;否＆＃34;。选择项目后，相邻的两个单元格将填充预定数据，如下所示：

上述宏工作，直到我右键单击并选择＆＃34;清除内容＆＃34;删除一系列值，如下所示：

以下是提出问题的代码：

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

Application.ScreenUpdating = False

Select Case Target

  Case "YES"
    If Target = "YES" Then
        Target.Offset(0, 1).Interior.ColorIndex = 6

            If Not Target.Cells.Count = 1 Then
                Exit Sub
                    If Intersect(Target, Columns(2)) Is Nothing Then
                        Exit Sub
                    End If
            End If
    End If
  Case Else
    If Target = "NO" Then
        Target.Offset(0, 1) = "NULL"
        Target.Offset(0, 2) = "NULL"
            If Not Target.Cells.Count = 1 Then
                Exit Sub
                    If Intersect(Target, Columns(2)) Is Nothing Then
                        Exit Sub
                            If Intersect(Target, Columns(2)) Is Nothing Then
                                Exit Sub
                            End If
                    End If
            End If
    End If
  End Select
End Sub

我试图弄清楚如何多次防止这种错误，但我还没有成功。我很感激任何帮助来解决这个问题！

Answer 1

在顶部添加以下内容：

If Target.Count > 1 then Exit Sub

因此，只要您选择了多个单元格，就可以退出sub。

Answer 2

假设您还要复制/粘贴一些＆＃34;是＆＃34; /＆＃34;否＆＃34;在那里，并希望它以正确的方式处理，这将以一个简单的方式做到：

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  If Intersect(Target, Columns(2)) Is Nothing Then Exit Sub
  Application.ScreenUpdating = False
  Dim cell
  For Each cell In Intersect(Target, Columns(2)).Cells
    If cell.Value = "Yes" Then
      cell.Offset(0, 1).Resize(1, 2).Interior.ColorIndex = 6
    ElseIf cell.Value = "No" Then
      cell.Offset(0, 1).Resize(1, 2).Value = "NULL"
    End If
  Next
End Sub

修改
范围设置为B1:B9999，因为清除整列可能会冻结excel。

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  If Intersect(Target, Target.Parent.Range("B1:B9999")) Is Nothing Then Exit Sub
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Dim cell
  For Each cell In Intersect(Target, Target.Parent.Range("B1:B9999")).Cells
    If cell.Value = "Yes" Then
      cell.Offset(0, 1).Resize(1, 2).Interior.ColorIndex = 6
      cell.Offset(0, 1).Resize(1, 2).ClearContents
    ElseIf cell.Value = "No" Then
      cell.Offset(0, 1).Resize(1, 2).Value = "NULL"
      cell.Offset(0, 1).Resize(1, 2).Interior.Pattern = xlNone
    Else
      cell.Offset(0, 1).Resize(1, 2).ClearContents
      cell.Offset(0, 1).Resize(1, 2).Interior.Pattern = xlNone
    End If
  Next
  Application.EnableEvents = True
End Sub

如果你只想清除＆＃34; NULL＆＃34;并撤消黄色，你需要先检查每个单元格，如下所示：

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  If Intersect(Target, Target.Parent.Range("B1:B9999")) Is Nothing Then Exit Sub
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Dim cell
  For Each cell In Intersect(Target, Target.Parent.Range("B1:B9999")).Cells
    If cell.Value = "Yes" Then
      cell.Offset(0, 1).Resize(1, 2).Interior.ColorIndex = 6
      If cell.Offset(0, 1).Value = "NULL" Then cell.Offset(0, 1).ClearContents
      If cell.Offset(0, 2).Value = "NULL" Then cell.Offset(0, 2).ClearContents
    ElseIf cell.Value = "No" Then
      cell.Offset(0, 1).Resize(1, 2).Value = "NULL"
      If cell.Offset(0, 1).Interior.ColorIndex = 6 Then cell.Offset(0, 1).Interior.Pattern = xlNone
      If cell.Offset(0, 2).Interior.ColorIndex = 6 Then cell.Offset(0, 2).Interior.Pattern = xlNone
    Else
      If cell.Offset(0, 1).Value = "NULL" Then cell.Offset(0, 1).ClearContents
      If cell.Offset(0, 2).Value = "NULL" Then cell.Offset(0, 2).ClearContents
      If cell.Offset(0, 1).Interior.ColorIndex = 6 Then cell.Offset(0, 1).Interior.Pattern = xlNone
      If cell.Offset(0, 2).Interior.ColorIndex = 6 Then cell.Offset(0, 2).Interior.Pattern = xlNone
    End If
  Next
  Application.EnableEvents = True
End Sub