excel - 对命名范围之外的单元格进行更改时出现 VBA Excel 运行时错误“1004”

Question

用例：我需要基于命名范围实现多选下拉菜单。我在多个工作表中定义了该命名范围。我认为下面的代码仅在使用“水果”的单元格中工作时执行。但是，每当我尝试更改任何页面上的任何单元格时，都会收到以下错误：

运行时错误“1004”：应用程序定义或对象定义错误调试器在第 10 行打开，当我将鼠标悬停在目标上时，它包含我添加到不属于“水果”范围的单元格的任何文本。

    If Not Intersect(Target, Sh.Range("HVA_Range")) Is Nothing Then

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim OldVal As String
    Dim NewVal As String

    ' If more than 1 cell is being changed
    If Target.Count > 1 Then Exit Sub
    If Target.Value = "" Then Exit Sub
    If Not Intersect(Target, Sh.Range("Fruits")) Is Nothing Then
        ' Turn off events so our changes don't trigger this event again
        Application.EnableEvents = False
        NewVal = Target.Value
        
        ' If there's nothing to undo this will cause an error
        On Error Resume Next
        Application.Undo
        On Error GoTo 0
        OldVal = Target.Value
        
        ' If selection is already in the cell we want to remove it
        If InStr(OldVal, NewVal) Then
            'If there's a comma in the cell, there's more than one word in the cell
            If InStr(OldVal, ",") Then
                If InStr(OldVal, ", " & NewVal) Then
                    Target.Value = Replace(OldVal, ", " & NewVal, "")
                Else
                    Target.Value = Replace(OldVal, NewVal & ", ", "")
                End If
            Else
                ' If we get to here the selection was the only thing in the cell
                Target.Value = ""
            End If
        Else
            If OldVal = "" Then
                Target.Value = NewVal
            Else
                ' Delete cell contents
                If NewVal = "" Then
                    Target.Value = NewVal
                Else
                    ' This IF prevents the same value appearing in the cell multiple times
                    ' If you are happy to have the same value multiple times remove this IF
                    If InStr(Target.Value, NewVal) = 0 Then
                        Target.Value = OldVal & ", " & NewVal
                    End If
                End If
            End If
        End If
        
        Application.EnableEvents = True
    Else
        Exit Sub
    End If
End Sub

当我使用对 Fruits 命名范围进行更改时，它似乎工作正常。

标签： excelvbadrop-down-menumulti-select

Answer 1

正如您所观察到的，在处理没有命名范围的工作表时会发生此错误。

您将需要检测名称的缺失，然后中止

If Not Intersect ...在行前添加这个

Dim nm as Name
On Error Resume Next
Set nm = Sh.Names("Fruits")
On Error GoTo 0
If nm Is Nothing Then Exit Sub

---

此代码中还有许多其他问题/操作可以解决

1. 陷阱错误是更改的工作表不是工作表
2. 如果多个单元格发生变化，而不是退出处理每个单元格
3. 允许用户输入几个逗号分隔的项目，处理每一个
4. 允许用户在逗号后省略或输入多个空格。在一个术语中保留多个空格。
5. 我曾经TextJoin重建分隔列表。如果您的 Excel 版本不支持，可以通过其他方式完成（请参阅注释掉的替代方案）

我已经包含了一个UpdateCell定义更新单元格规则的子程序。如果我的解释与你的不符，请告诉我。

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    ' To allow multiple selections in a Drop Down List in Excel (without repetition)
    Dim ws As Worksheet
    Dim nm As Name
    Dim OldValue As Variant
    Dim NewValue As Variant
    Dim rChanged As Range
    Dim TargetArea As Range
    Dim TargetAreaVal As Range
    Dim a As Long
    Dim r As Long
    Dim c As Long
    Dim i As Long
    Dim n As Long
    Dim NamedRange As String
    
    NamedRange = "Fruits" ' change to suit your needs
    
    ' Check for Changes we don't want to process
    '   Sh is not a Worksheet
    On Error Resume Next
        Set ws = Sh
        If ws Is Nothing Then Exit Sub
    
    '   No Named range on sheet
        Set nm = ws.Names(NamedRange)
        If nm Is Nothing Then Exit Sub
    
    ' Use handler to ensure Events are turned back on
    On Error GoTo EH
    Set rChanged = Application.Intersect(Target, nm.RefersToRange)

    If Not rChanged Is Nothing Then
        Application.EnableEvents = False
        ' Use Jagged Arrays to allow for non-contiguous ranges
        ReDim NewValue(1 To Target.Areas.Count)
        ReDim OldValue(1 To Target.Areas.Count)
        
        For a = 1 To Target.Areas.Count
            NewValue(a) = Target.Areas(a).Value2
        Next
        
        Application.Undo
        For a = 1 To Target.Areas.Count
            OldValue(a) = Target.Areas(a).Value2
        Next
        Application.Undo ' restores original state
        
        ' For each non-contiguous range
        For a = 1 To UBound(NewValue)
            n = 0
            On Error Resume Next
               n = UBound(NewValue(a), 1)
            On Error GoTo EH
            Set TargetArea = rChanged.Areas(a).Cells
            If n = 0 Then
                ' Single Cell in Area
                UpdateCell TargetArea, OldValue(a), NewValue(a)
            Else
                ' Multiple Cells in Area
                For r = 1 To UBound(NewValue(a), 1)
                    For c = 1 To UBound(NewValue(a), 2)
                        UpdateCell TargetArea.Cells(r, c), OldValue(a)(r, c), NewValue(a)(r, c)
                    Next
                Next
            End If
        Next
    End If
EH:
    Application.EnableEvents = True

End Sub


Private Sub UpdateCell(ByVal cl As Range, OldValue As Variant, NewValue As Variant)
    ' Update rules, in priority order
    ' 1.  NewValue is Blank - delete contents (leave cell as it is)
    ' 2.  NewValue contains commas - loop each value
    ' 3.  OldValue contains NewValue - remove it
    ' 4.  Else, Add NewValue to OldValue
    
    Dim OldValues() As String
    Dim NewValues() As String
    Dim i As Long
    
    If NewValue = vbNullString Then
        '1. do nothing
    Else
        '   Account for possibility user doesnt include a space after the comma, or includes several spaces
        Do While NewValue Like "*, *"
            NewValue = Replace$(NewValue, ", ", ",")
        Loop
        Do While OldValue Like "*, *"
            OldValue = Replace$(OldValue, ", ", ",")
        Loop
        
        OldValues = Split(OldValue, ",")
        NewValues = Split(NewValue, ",")
        If LBound(NewValues) < UBound(NewValues) Then
            ' Multiple NewValue
            For i = LBound(NewValues) To UBound(NewValues)
                '2. Loop for each NewValue
                UpdateCell cl, OldValue, NewValues(i)
            Next
        Else
            ' Single NewValue
            For i = LBound(OldValues) To UBound(OldValues)
                If OldValues(i) = NewValue Then
                    ' 3. remove it
                    OldValues(i) = vbNullString
                    Exit For
                End If
            Next
            If i > UBound(OldValues) Then
                ' 4. Wasn't found, add it
                ReDim Preserve OldValues(LBound(OldValues) To UBound(OldValues) + 1)
                OldValues(UBound(OldValues)) = NewValue
            End If
            ' Rebuild Value
            OldValue = Application.TextJoin(",", True, OldValues)

            ' Alternative if TextJoin isnt available
'            OldValue = Join(OldValues, ",")
'            Do While OldValue Like "*,,*"
'                OldValue = Replace$(OldValue, ",,", ",")
'            Loop
'            If OldValue Like ",*" Then OldValue = Mid$(OldValue, 2)
'            If OldValue Like "*," Then OldValue = Left$(OldValue, Len(OldValue) - 1)
            

            ' restore spaces after commas
            cl.Value2 = Replace$(OldValue, ",", ", ")
        End If
    End If
    

End Sub