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

我有一个macros将根据下拉select填充多个列中的一个值或一个黄色。 例如，下拉列表包含两个项目，“是”和“否”。 当select一个项目时，相邻的两个单元格将填充预定的数据，如下所示：

上面的macros一直工作，直到我右键单击并select“清除内容”来删除一个值的范围，如下所示：

以下是显示问题的代码：

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

因此，只要您select了多个单元格，就可以退出该子程序。

Answer 2

假设你也想在那里复制/粘贴一些“是”/“否”，并希望以正确的方式处理它，这将以简单的方式完成：

 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 

如果您只想清除“NULL”并撤消黄色，则需要先检查每个单元格，如下所示：

 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